VBA/VBS to create new workbook

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
Good day all, I apologize if this is not the correct forum for this, I wasn't 100% sure where to ask. I hope what I am about to ask, makes sense.

I have a workbook that can contain up do 100k lines of data in it, that is used to perform audits. We have to break this down using the DIVISION column, to ensure we are sending only Division Ford data to that Division Chief.

I am trying to come up with a script that we could execute, that would read the workbook, and create new workbooks based off the division column, with all the other info that would be populated in the rows.

eg. Rows 2 - 150 lists Ford and 151 - 200 lists AMG in the DIVISION column, create new workbooks (FORD and AMG) with the header row and the matching data for each division.

Example of the workbook attached
 

Attachments

  • Capture.JPG
    Capture.JPG
    146.1 KB · Views: 9

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,755
Hi juneau730,

Let me know how this goes:

VBA Code:
Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim strSavePath As String, strLastCol As String
    Dim clnDivisions As New Collection
    Dim lngMyRow As Long, lngLastRow As Long, lngLastCol As Long, i As Long
    Dim varDivision As Variant
    Dim rngFiltered As Range
    Dim wb As Workbook
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the divisions in column E. Change to suit.
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    strSavePath = "C:\Users" 'Path to save individual division workbooks. Change to suit.
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Split(wsSrc.Cells(lngLastRow, lngLastCol).Address, "$")(1)
    
    'Create an unique list of divisions
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            clnDivisions.Add CStr(wsSrc.Range("E" & lngMyRow)), wsSrc.Range("E" & lngMyRow)
        On Error GoTo 0
    Next lngMyRow
    
    'Create and save a new workbook for each division (the new workbook will only have the sheet with the data)
    For Each varDivision In clnDivisions
        wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).AutoFilter Field:=5, Criteria1:=CStr(varDivision), Operator:=xlFilterValues
        Set rngFiltered = wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
        If Not rngFiltered Is Nothing Then
            Set wb = Workbooks.Add(1)
            rngFiltered.Copy
            With wb.Sheets(1).Range("A1")
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                .Select
            End With
            i = i + 1
            Application.DisplayAlerts = False 'Save over a workbook with the same name, no questions asked
                wb.SaveAs strSavePath & CStr(varDivision) & ".xlsx", 51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
                wb.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
        On Error Resume Next
            wsSrc.ShowAllData
        On Error GoTo 0
    Next varDivision
    
    Application.ScreenUpdating = False
    
    If i = 0 Then
        MsgBox "There were no unique entries in Col. E of """ & wsSrc.Name & """ to create any workbooks.", vbExclamation
    Else
        MsgBox Format(i, "#,##0") & " division workbooks have now been saved in """ & strSavePath & """", vbInformation
    End If

End Sub

Regards,

Robert
 

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
Hi juneau730,

Let me know how this goes:

VBA Code:
Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim strSavePath As String, strLastCol As String
    Dim clnDivisions As New Collection
    Dim lngMyRow As Long, lngLastRow As Long, lngLastCol As Long, i As Long
    Dim varDivision As Variant
    Dim rngFiltered As Range
    Dim wb As Workbook
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the divisions in column E. Change to suit.
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    strSavePath = "C:\Users" 'Path to save individual division workbooks. Change to suit.
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Split(wsSrc.Cells(lngLastRow, lngLastCol).Address, "$")(1)
   
    'Create an unique list of divisions
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            clnDivisions.Add CStr(wsSrc.Range("E" & lngMyRow)), wsSrc.Range("E" & lngMyRow)
        On Error GoTo 0
    Next lngMyRow
   
    'Create and save a new workbook for each division (the new workbook will only have the sheet with the data)
    For Each varDivision In clnDivisions
        wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).AutoFilter Field:=5, Criteria1:=CStr(varDivision), Operator:=xlFilterValues
        Set rngFiltered = wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
        If Not rngFiltered Is Nothing Then
            Set wb = Workbooks.Add(1)
            rngFiltered.Copy
            With wb.Sheets(1).Range("A1")
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                .Select
            End With
            i = i + 1
            Application.DisplayAlerts = False 'Save over a workbook with the same name, no questions asked
                wb.SaveAs strSavePath & CStr(varDivision) & ".xlsx", 51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
                wb.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
        On Error Resume Next
            wsSrc.ShowAllData
        On Error GoTo 0
    Next varDivision
   
    Application.ScreenUpdating = False
   
    If i = 0 Then
        MsgBox "There were no unique entries in Col. E of """ & wsSrc.Name & """ to create any workbooks.", vbExclamation
    Else
        MsgBox Format(i, "#,##0") & " division workbooks have now been saved in """ & strSavePath & """", vbInformation
    End If

End Sub

Regards,

Robert
Robert, thank you very much for this, I will be giving it a whirl today and see how it plays out!
 

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
Hi juneau730,

Let me know how this goes:

VBA Code:
Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim strSavePath As String, strLastCol As String
    Dim clnDivisions As New Collection
    Dim lngMyRow As Long, lngLastRow As Long, lngLastCol As Long, i As Long
    Dim varDivision As Variant
    Dim rngFiltered As Range
    Dim wb As Workbook
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the divisions in column E. Change to suit.
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    strSavePath = "C:\Users" 'Path to save individual division workbooks. Change to suit.
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Split(wsSrc.Cells(lngLastRow, lngLastCol).Address, "$")(1)
   
    'Create an unique list of divisions
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            clnDivisions.Add CStr(wsSrc.Range("E" & lngMyRow)), wsSrc.Range("E" & lngMyRow)
        On Error GoTo 0
    Next lngMyRow
   
    'Create and save a new workbook for each division (the new workbook will only have the sheet with the data)
    For Each varDivision In clnDivisions
        wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).AutoFilter Field:=5, Criteria1:=CStr(varDivision), Operator:=xlFilterValues
        Set rngFiltered = wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
        If Not rngFiltered Is Nothing Then
            Set wb = Workbooks.Add(1)
            rngFiltered.Copy
            With wb.Sheets(1).Range("A1")
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                .Select
            End With
            i = i + 1
            Application.DisplayAlerts = False 'Save over a workbook with the same name, no questions asked
                wb.SaveAs strSavePath & CStr(varDivision) & ".xlsx", 51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
                wb.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
        On Error Resume Next
            wsSrc.ShowAllData
        On Error GoTo 0
    Next varDivision
   
    Application.ScreenUpdating = False
   
    If i = 0 Then
        MsgBox "There were no unique entries in Col. E of """ & wsSrc.Name & """ to create any workbooks.", vbExclamation
    Else
        MsgBox Format(i, "#,##0") & " division workbooks have now been saved in """ & strSavePath & """", vbInformation
    End If

End Sub

Regards,

Robert
Hey Robert,
Had a chance to test this, also had a few others test it with some mixed results that have me scratching my head.
Of the 4 that tested it, one was able to get it to work and it worked exactly like it should. The others get a 400 error, we click ok and it creates one spreadsheet, then stops. Can't figure this one out yet. The location I changed the save path to, we have full write permissions, so I would not suspect that's the error.
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,755

ADVERTISEMENT

Hey Robert,
Had a chance to test this, also had a few others test it with some mixed results that have me scratching my head.
Of the 4 that tested it, one was able to get it to work and it worked exactly like it should. The others get a 400 error, we click ok and it creates one spreadsheet, then stops. Can't figure this one out yet. The location I changed the save path to, we have full write permissions, so I would not suspect that's the error.

Not sure as it worked for me (albeit on a small amount of test data) :confused:

Check what the macro settings are on the person's machine that worked and ensure they are the same on everyone else's and though I don't use early binding make sure there's no references in the Visual Basic Editor that starting with the text MISSING.

This article says it could be improperly configured settings or due to irregular Windows registry entries not the code.

Hope that helps,

Robert
 

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
Not sure as it worked for me (albeit on a small amount of test data) :confused:

Check what the macro settings are on the person's machine that worked and ensure they are the same on everyone else's and though I don't use early binding make sure there's no references in the Visual Basic Editor that starting with the text MISSING.

This article says it could be improperly configured settings or due to irregular Windows registry entries not the code.

Hope that helps,

Robert
I am not 100% sure what was going on, but it is working now and it's doing exactly what is needed!

Only need one tweak to it, before it starts to read sheet 1 and create the new workbooks, I need it to replace some characters. I recorded the macro, I am just not sure what to integrate it into the original one.

I presume it would go before here: strSavePath = "%USERPROFILE%\Desktop\CMAT_FY22_Test\VBA_Reports\" 'Path to save individual division workbooks. Change to suit.

VBA Code:
Sub Macro2()
'
    Columns("E:E").Select
    Selection.Replace What:="\", Replacement:="_", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="/", Replacement:="_", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,755

ADVERTISEMENT

I am not 100% sure what was going on, but it is working now and it's doing exactly what is needed!

That does seem odd but if it's now working reliably that's great.

Only need one tweak to it, before it starts to read sheet 1 and create the new workbooks

Your screen shot from your original post (which should accurately reflect your data) only has a name so not sure why you're now trying to replace text :confused: The strSavePath is a string variable used to house a single directory path for each file to be saved to. The code you recorded replaces all the matching text in Col. E. so I'm not sure what you're trying to achieve.
 

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
That does seem odd but if it's now working reliably that's great.



Your screen shot from your original post (which should accurately reflect your data) only has a name so not sure why you're now trying to replace text :confused: The strSavePath is a string variable used to house a single directory path for each file to be saved to. The code you recorded replaces all the matching text in Col. E. so I'm not sure what you're trying to achieve.
GM Robert,
The screenshot I provided was only a sample of the format of the workbook. Do to the sensitivity of the data we actually pull, I am not able to provide "live" data. The live data in that column in that column does (unfortunately) contain both forward and backward slashes, which the code is erroring out on. By doing a manual find/replace all on them and putting a dash or underscore, fixes the issue.
 

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
89
I was able to get the "replace" code inserted into the original code and it works. Thank you so much for your help with this Robert. Here is the complete code, if it can help anyone else

VBA Code:
Sub Macro1 ()

    Dim wsSrc As Worksheet
    Dim strSavePath As String, strLastCol As String
    Dim clnDivisions As New Collection
    Dim lngMyRow As Long, lngLastRow As Long, lngLastCol As Long, i As Long
    Dim varDivision As Variant
    Dim rngFiltered As Range
    Dim wb As Workbook
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the divisions in column E. Change to suit.
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0

   Columns("E:E").Select
    Selection.Replace What:="\", Replacement:="_", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="/", Replacement:="_", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

    strSavePath = "%USERPROFILE%\Desktop\test\" 'Path to save individual division workbooks. Change to suit.
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
    lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    strLastCol = Split(wsSrc.Cells(lngLastRow, lngLastCol).Address, "$")(1)
    
    'Create an unique list of divisions
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            clnDivisions.Add CStr(wsSrc.Range("E" & lngMyRow)), wsSrc.Range("E" & lngMyRow)
        On Error GoTo 0
    Next lngMyRow
    
    'Create and save a new workbook for each division (the new workbook will only have the sheet with the data)
    For Each varDivision In clnDivisions
        wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).AutoFilter Field:=5, Criteria1:=CStr(varDivision), Operator:=xlFilterValues
        Set rngFiltered = wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
        If Not rngFiltered Is Nothing Then
            Set wb = Workbooks.Add(1)
            rngFiltered.Copy
            With wb.Sheets(1).Range("A1")
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                .Select
            End With
            i = i + 1
            Application.DisplayAlerts = False 'Save over a workbook with the same name, no questions asked
                wb.SaveAs strSavePath & CStr(varDivision) & ".xlsx", 51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
                wb.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
        On Error Resume Next
            wsSrc.ShowAllData
        On Error GoTo 0
    Next varDivision
    
    Application.ScreenUpdating = False
    
    If i = 0 Then
        MsgBox "There were no unique entries in Col. E of """ & wsSrc.Name & """ to create any workbooks.", vbExclamation
    Else
        MsgBox Format(i, "#,##0") & " division workbooks have now been saved in """ & strSavePath & """", vbInformation
    End If

End Sub
 

Forum statistics

Threads
1,137,060
Messages
5,679,380
Members
419,824
Latest member
Mercy kiara

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top