VBA/VBS to create new workbook

J

juneau730

Board Regular
Joined
Jun 7, 2018
Messages
111
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: 11

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
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
 
Upvote 0
Trebor76 said:
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
Click to expand...
Robert, thank you very much for this, I will be giving it a whirl today and see how it plays out!
 
Upvote 0
Trebor76 said:
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
Click to expand...
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.
 
Upvote 0
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.
Click to expand...

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
 
Upvote 0
Trebor76 said:
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
Click to expand...
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
 
Upvote 0
I am not 100% sure what was going on, but it is working now and it's doing exactly what is needed!
Click to expand...

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
Click to expand...

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.
 
Upvote 0
Trebor76 said:
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.
Click to expand...
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.
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA to loop through sheets and copy to new workbook including the pivot tab
Replies
0
Views
177
simont1975
S
U
  • Solved
Creating Workbooks with Page Breaks
Replies
2
Views
70
UT_CL
U
Guna13
  • Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
78
Guna13
Guna13
M
  • Question
VBA help required in creating multiple workbooks from one workbook.
Replies
5
Views
257
jolivanes
jolivanes
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
122
kizzie37
K

Forum statistics

Threads
1,214,422
Messages
6,119,396
Members
448,891
Latest member
tpierce

Share this page

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
Back
Top