VBA - Copy All Rows Containing Given String in Sheet1 Col B & Sheet2 Col A into New Workbook with Same Layout

[CatDad]

VBA newbie here. I'm starting with a single workbook that has 2 sheets. With this, I'm trying to figure out code that would accomplish the following on execution:

1. Create an Array with n elements, where n is the number of Unique Strings found within the Cells in Column B (excluding B1 and blanks) from Sheet1 in the Source Workbook
2. Populate the Array with each of these Unique Strings
3. Enter a loop:
   1. Start with String Array(0)
   2. Create a new Target Workbook that is a Copy of Source Workbook
   3. Delete every Row in new Target Workbook EXCEPT
      • Row 1 in both Sheet1 and Sheet2 (Headers)
      • Rows in Sheet1 where Column B equals/contains String Array(0)
      • Rows in Sheet2 where Column A contains (not equals!) String Array(0)
   4. Save new Target Workbook with filename matching Source Workbook's but prefaced by String Array(0) (same folder)
   5. Repeat for Array(1), Array(2)...Array (with n being the final element)

Any help would be greatly appreciated!

 

[kevin9999]

This is quite an ask, and I doubt if I've got this right first time, but the following code does work on some mock-up data I created - based on my interpretation of what you want. It would really help if you could provide some actual data using the XL2BB add in so we don't have to guess what your actual sheet(s) look like. Run the code from the source workbook. See how you go...

Option Explicit
Sub CatDad()

    'Get the array of unique strings
    Dim d As Object, Arr, x, i As Long, ws As Worksheet, tmp As String
    Set ws = Sheet1
    Set d = CreateObject("scripting.dictionary")
    x = Application.Transpose(ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)))
    For i = 1 To UBound(x, 1)
        d(x(i)) = 1
    Next
    tmp = ""
    If d.exists(tmp) Then d.Remove (tmp)
    Arr = Application.Transpose(d.keys)
    
    'Create a new file & clear all data
    tmp = Arr(1, 1) & " "
    Dim NewFileName As String
    NewFileName = ThisWorkbook.Path & "\" & tmp & ThisWorkbook.Name
    ThisWorkbook.SaveCopyAs NewFileName
    Workbooks.Open NewFileName
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    wb.Sheets(1).UsedRange.Offset(1).ClearContents
    wb.Sheets(2).UsedRange.Offset(1).ClearContents
    
    'Copy the data as per the parameters outlined
    With Sheet1.Range("A1").CurrentRegion
        .AutoFilter 2, Array(d.keys), 7
        .Offset(1).Copy wb.Sheets(1).Range("A2")
        .AutoFilter
    End With
    
    Dim LRow As Long
    LRow = wb.Sheets(2).Cells(Rows.Count, 1).End(3).Row + 1
    For i = 1 To UBound(Arr, 1)
        With Sheet1.Range("A1").CurrentRegion
            .AutoFilter 1, "*" & Arr(i, 1) & "*", 1, "<>" & Arr(i, 1)
            .Offset(1).Copy wb.Sheets(2).Range("A" & LRow)
            LRow = wb.Sheets(2).Cells(Rows.Count, 1).End(3).Row + 1
            .AutoFilter
        End With
    Next i

End Sub

 

[CatDad]

This is quite an ask, and I doubt if I've got this right first time, but the following code does work on some mock-up data I created - based on my interpretation of what you want. It would really help if you could provide some actual data using the XL2BB add in so we don't have to guess what your actual sheet(s) look like. Run the code from the source workbook. See how you go...

Option Explicit
Sub CatDad()

    'Get the array of unique strings
    Dim d As Object, Arr, x, i As Long, ws As Worksheet, tmp As String
    Set ws = Sheet1
    Set d = CreateObject("scripting.dictionary")
    x = Application.Transpose(ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)))
    For i = 1 To UBound(x, 1)
        d(x(i)) = 1
    Next
    tmp = ""
    If d.exists(tmp) Then d.Remove (tmp)
    Arr = Application.Transpose(d.keys)
   
    'Create a new file & clear all data
    tmp = Arr(1, 1) & " "
    Dim NewFileName As String
    NewFileName = ThisWorkbook.Path & "\" & tmp & ThisWorkbook.Name
    ThisWorkbook.SaveCopyAs NewFileName
    Workbooks.Open NewFileName
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    wb.Sheets(1).UsedRange.Offset(1).ClearContents
    wb.Sheets(2).UsedRange.Offset(1).ClearContents
   
    'Copy the data as per the parameters outlined
    With Sheet1.Range("A1").CurrentRegion
        .AutoFilter 2, Array(d.keys), 7
        .Offset(1).Copy wb.Sheets(1).Range("A2")
        .AutoFilter
    End With
   
    Dim LRow As Long
    LRow = wb.Sheets(2).Cells(Rows.Count, 1).End(3).Row + 1
    For i = 1 To UBound(Arr, 1)
        With Sheet1.Range("A1").CurrentRegion
            .AutoFilter 1, "*" & Arr(i, 1) & "*", 1, "<>" & Arr(i, 1)
            .Offset(1).Copy wb.Sheets(2).Range("A" & LRow)
            LRow = wb.Sheets(2).Cells(Rows.Count, 1).End(3).Row + 1
            .AutoFilter
        End With
    Next i

End Sub

Hi Kevin,

Firstly, I'm overwhelmed with gratitude for your help, and while your code doesn't seem to get the desired end result, I absolutely take accountability for that per the lack of example data/additional context in my original post. My apologies!

Additional context regarding any given Source Workbook that will be used with this code (hopefully not overcomplicating):

• Never utilizes formulas in their Cells, only Strings and Numbers. Despite having a "Totals" row on Sheet2 of the Source Workbook, these Values are still just Numbers (and this Row is ultimately never present in the New Target Workbooks anyway).
• The number of Unique Strings in Sheet1 Column B will always equal the number of Unique Strings in Sheet2 Column A (minus the "Totals" row).
• For every UniqueString in Sheet1 Column B, there will always be only one corresponding Sheet2 Column A String that contains the Sheet1 Column B String as a Substring(?) in square brackets.
  • Sheet1 Column B often contains repeating String Values while Sheet2 Column A will always contain only one of each of these.

Here is a simplified example using mock data:


Source Workbook:

Sheet1:

ExampleReportName.xlsm
	A	B	C	D
1	EmployeeName	Distribution	Gross	Net
2	TEST, TEST	0001	123.45	100.12
3	REAL, NOT	0001	52.34	42.32
4	TEST, TEST	0123	69.41	57.89
5	DOE, JOHN	1002	6.87	5
Report Data

Sheet2:

ExampleReportName.xlsm
	A	B	C
1	Distribution	Gross	Net
2	Place[0001]	175.79	142.44
3	The Spot[0123]	69.41	57.89
4	Hub [1002]	6.87	5
5	Totals	252.07	205.33
Distribution Summary

VBA Code Desired Output:


New Target Workbook1:

Sheet1:

0001 ExampleReportName.xlsm
	A	B	C	D
1	EmployeeName	Distribution	Gross	Net
2	TEST, TEST	0001	123.45	100.12
3	REAL, NOT	0001	52.34	42.32
Report Data

Sheet2:

0001 ExampleReportName.xlsm
	A	B	C
1	Distribution	Gross	Net
2	Place[0001]	175.79	142.44
Distribution Summary

New Target Workbook2:

Sheet1:

0123 ExampleReportName.xlsm
	A	B	C	D
1	EmployeeName	Distribution	Gross	Net
2	TEST, TEST	0123	69.41	57.89
Report Data

Sheet2:

0123 ExampleReportName.xlsm
	A	B	C
1	Distribution	Gross	Net
2	The Spot[0123]	69.41	57.89
Distribution Summary

New Target Workbook3:

Sheet1:

1002 ExampleReportName.xlsm
	A	B	C	D
1	EmployeeName	Distribution	Gross	Net
2	DOE, JOHN	1002	6.87	5
Report Data

Sheet2:

1002 ExampleReportName.xlsm
	A	B	C
1	Distribution	Gross	Net
2	Hub [1002]	6.87	5
Distribution Summary

 

[kevin9999]

Thank you for providing a clearer picture of what we're faced with, much appreciated
The real trick here is going to be the values in column B of sheet 1 - they look like numbers formatted as "0000" (they're to the right of the cell) but if they're text, we may need to tweak the code below. Let me know how it goes (it works for me & gives you exactly what you have above - with the proviso that the values are numbers).

Option Explicit
Sub CatDad2()
    Application.ScreenUpdating = 0
    'Get the array of unique strings
    Dim d As Object, Arr, x, i As Long, ws As Worksheet, tmp As String
    Dim wb As Workbook
    Set ws = Sheet1
    Set d = CreateObject("scripting.dictionary")
    x = Application.Transpose(ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)))
    For i = 1 To UBound(x, 1)
        d(x(i)) = 1
    Next
    tmp = ""
    If d.exists(tmp) Then d.Remove (tmp)
    Arr = Application.Transpose(d.keys)
    
    For i = 1 To UBound(Arr, 1)
        Arr(i, 1) = Format(Arr(i, 1), "0000")
    Debug.Print Arr(i, 1)
    Next i
    
    'Loop through each array element, create new files & copy data
    For i = 1 To UBound(Arr, 1)
    
        'Create a new file & clear all data
        tmp = CStr(Arr(i, 1)) & " "
        Dim NewFileName As String
        NewFileName = ThisWorkbook.Path & "\" & tmp & ThisWorkbook.Name
        ThisWorkbook.SaveCopyAs NewFileName
        Workbooks.Open NewFileName
        Set wb = ActiveWorkbook
        wb.Sheets(1).UsedRange.Offset(1).ClearContents
        wb.Sheets(2).UsedRange.Offset(1).ClearContents
        
        'Copy the data as per the parameters outlined
        With Sheet1.Range("A1").CurrentRegion
            .AutoFilter 2, Arr(i, 1), 7
            .Offset(1).Copy wb.Sheets(1).Range("A2")
            .AutoFilter
        End With
        
        With Sheet2.Range("A1").CurrentRegion
            .AutoFilter 1, "*" & Arr(i, 1) & "*"
            .Offset(1).Copy wb.Sheets(2).Range("A2")
            .AutoFilter
        End With
        
        wb.Close True
    Next i
    Application.ScreenUpdating = 1
End Sub

 

[CatDad]

Thank you for providing a clearer picture of what we're faced with, much appreciated
The real trick here is going to be the values in column B of sheet 1 - they look like numbers formatted as "0000" (they're to the right of the cell) but if they're text, we may need to tweak the code below. Let me know how it goes (it works for me & gives you exactly what you have above - with the proviso that the values are numbers).

Option Explicit
Sub CatDad2()
    Application.ScreenUpdating = 0
    'Get the array of unique strings
    Dim d As Object, Arr, x, i As Long, ws As Worksheet, tmp As String
    Dim wb As Workbook
    Set ws = Sheet1
    Set d = CreateObject("scripting.dictionary")
    x = Application.Transpose(ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)))
    For i = 1 To UBound(x, 1)
        d(x(i)) = 1
    Next
    tmp = ""
    If d.exists(tmp) Then d.Remove (tmp)
    Arr = Application.Transpose(d.keys)
   
    For i = 1 To UBound(Arr, 1)
        Arr(i, 1) = Format(Arr(i, 1), "0000")
    Debug.Print Arr(i, 1)
    Next i
   
    'Loop through each array element, create new files & copy data
    For i = 1 To UBound(Arr, 1)
   
        'Create a new file & clear all data
        tmp = CStr(Arr(i, 1)) & " "
        Dim NewFileName As String
        NewFileName = ThisWorkbook.Path & "\" & tmp & ThisWorkbook.Name
        ThisWorkbook.SaveCopyAs NewFileName
        Workbooks.Open NewFileName
        Set wb = ActiveWorkbook
        wb.Sheets(1).UsedRange.Offset(1).ClearContents
        wb.Sheets(2).UsedRange.Offset(1).ClearContents
       
        'Copy the data as per the parameters outlined
        With Sheet1.Range("A1").CurrentRegion
            .AutoFilter 2, Arr(i, 1), 7
            .Offset(1).Copy wb.Sheets(1).Range("A2")
            .AutoFilter
        End With
       
        With Sheet2.Range("A1").CurrentRegion
            .AutoFilter 1, "*" & Arr(i, 1) & "*"
            .Offset(1).Copy wb.Sheets(2).Range("A2")
            .AutoFilter
        End With
       
        wb.Close True
    Next i
    Application.ScreenUpdating = 1
End Sub

Success! While the Sheet1 Column B Values are technically text, your code seems to work just fine with them.

Thank you so much!

 

[kevin9999]

Success! While the Sheet1 Column B Values are technically text, your code seems to work just fine with them.

Thank you so much!

Happy to help, and thanks for the feedback