Excel master workbook to separate workbooks splitting

[premsaradhi]

Hi all,

I have an excel workbook having some huge data.

I need to split the master workbook into separate workbooks. The splitting of data should take place whenever it finds an empty row.(splitting spot).

And I want the newly created workbooks to have below conditions:

1) A filename with serial number (Ex: BV0001, BV0002, BV0003,... and so on.
2) Same header from master file should be pasted in all new files
3) In all new files data must pasted be in "Sheet1".

 

[Herakles]

Try this using a copy of your data.

Set the path where the files are to be saved using the strPath variable.

The worksheet containing the data is to be the active worksheet.

Public Sub subSplitData()
Dim rngSplit As Range
Dim i As Integer
Dim WsWip As Worksheet
Dim strPath As String

    ActiveWorkbook.Save
    
    strPath = ActiveWorkbook.Path & "\"
        
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
            
    Set WsWip = ActiveSheet
    
    Application.ScreenUpdating = False
    
    Application.DisplayAlerts = False
    
    Do While Len(WsWip.Range("A2").Value) > 0
    
        i = i + 1
    
        Set rngSplit = WsWip.Range("A1").CurrentRegion
                     
        Workbooks.Add
        
        rngSplit.Copy Sheets("Sheet1").Range("A1")
        
        Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
        
        ActiveWorkbook.SaveAs strPath & "BV" & Right("0000" & i, 4)
        
        ActiveWorkbook.Close
        
        WsWip.Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
        
    Loop
    
    WsWip.Delete
    
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    ActiveWorkbook.Save
        
    MsgBox i & " workbooks have been created.", vbInformation, "Confirmation"

End Sub

 

[premsaradhi]

Try this using a copy of your data.

Set the path where the files are to be saved using the strPath variable.

The worksheet containing the data is to be the active worksheet.

Public Sub subSplitData()
Dim rngSplit As Range
Dim i As Integer
Dim WsWip As Worksheet
Dim strPath As String

    ActiveWorkbook.Save
   
    strPath = ActiveWorkbook.Path & "\"
       
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
           
    Set WsWip = ActiveSheet
   
    Application.ScreenUpdating = False
   
    Application.DisplayAlerts = False
   
    Do While Len(WsWip.Range("A2").Value) > 0
   
        i = i + 1
   
        Set rngSplit = WsWip.Range("A1").CurrentRegion
                    
        Workbooks.Add
       
        rngSplit.Copy Sheets("Sheet1").Range("A1")
       
        Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
       
        ActiveWorkbook.SaveAs strPath & "BV" & Right("0000" & i, 4)
       
        ActiveWorkbook.Close
       
        WsWip.Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
       
    Loop
   
    WsWip.Delete
   
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
   
    ActiveWorkbook.Save
       
    MsgBox i & " workbooks have been created.", vbInformation, "Confirmation"

End Sub

Thanks a lot sir..... It's working perfectly. Thank you thank you thank you sir.....

 

[premsaradhi]

Thanks a lot sir..... It's working perfectly. Thank you thank you thank you sir.....

Sir,
If I want start the program from number "BV0000000010446" what should I change in the above code

 

[Herakles]

This should work but do you want that number to increment each time you run this?

Public Sub subSplitData()
Dim rngSplit As Range
Dim i As Long
Dim WsWip As Worksheet
Dim strPath As String
Dim intCounter As Integer

    ActiveWorkbook.Save
    
    strPath = ActiveWorkbook.Path & "\"
        
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
            
    Set WsWip = ActiveSheet
    
    Application.ScreenUpdating = False
    
    Application.DisplayAlerts = False
    
    i = 10446
    
    Do While Len(WsWip.Range("A2").Value) > 0
    
        intCounter = intCounter + 1
    
        Set rngSplit = WsWip.Range("A1").CurrentRegion
                     
        Workbooks.Add
        
        rngSplit.Copy Sheets("Sheet1").Range("A1")
        
        Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
        
        ActiveWorkbook.SaveAs strPath & "BV00000000" & i
        
        ActiveWorkbook.Close
        
        WsWip.Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
        
        i = i + 1
                
    Loop
    
    WsWip.Delete
    
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    ActiveWorkbook.Save
        
    MsgBox intCounter & " workbooks have been created.", vbInformation, "Confirmation"

End Sub

 

[Peter_SSs]

Thanks a lot sir..... It's working perfectly. Thank you thank you thank you sir.....

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.

 

[premsaradhi]

This should work but do you want that number to increment each time you run this?

Public Sub subSplitData()
Dim rngSplit As Range
Dim i As Long
Dim WsWip As Worksheet
Dim strPath As String
Dim intCounter As Integer

    ActiveWorkbook.Save
  
    strPath = ActiveWorkbook.Path & "\"
      
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
          
    Set WsWip = ActiveSheet
  
    Application.ScreenUpdating = False
  
    Application.DisplayAlerts = False
  
    i = 10446
  
    Do While Len(WsWip.Range("A2").Value) > 0
  
        intCounter = intCounter + 1
  
        Set rngSplit = WsWip.Range("A1").CurrentRegion
                   
        Workbooks.Add
      
        rngSplit.Copy Sheets("Sheet1").Range("A1")
      
        Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
      
        ActiveWorkbook.SaveAs strPath & "BV00000000" & i
      
        ActiveWorkbook.Close
      
        WsWip.Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
      
        i = i + 1
              
    Loop
  
    WsWip.Delete
  
    Application.DisplayAlerts = True
  
    Application.ScreenUpdating = True
  
    ActiveWorkbook.Save
      
    MsgBox intCounter & " workbooks have been created.", vbInformation, "Confirmation"

End Sub

This should work but do you want that number to increment each time you run this?

Public Sub subSplitData()
Dim rngSplit As Range
Dim i As Long
Dim WsWip As Worksheet
Dim strPath As String
Dim intCounter As Integer

    ActiveWorkbook.Save
   
    strPath = ActiveWorkbook.Path & "\"
       
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
           
    Set WsWip = ActiveSheet
   
    Application.ScreenUpdating = False
   
    Application.DisplayAlerts = False
   
    i = 10446
   
    Do While Len(WsWip.Range("A2").Value) > 0
   
        intCounter = intCounter + 1
   
        Set rngSplit = WsWip.Range("A1").CurrentRegion
                    
        Workbooks.Add
       
        rngSplit.Copy Sheets("Sheet1").Range("A1")
       
        Sheets("Sheet1").UsedRange.EntireColumn.AutoFit
       
        ActiveWorkbook.SaveAs strPath & "BV00000000" & i
       
        ActiveWorkbook.Close
       
        WsWip.Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
       
        i = i + 1
               
    Loop
   
    WsWip.Delete
   
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
   
    ActiveWorkbook.Save
       
    MsgBox intCounter & " workbooks have been created.", vbInformation, "Confirmation"

End Sub

Superb....Many thanks you sir "herakles"