Macro to extract data into seperate workbooks

[Kim B]

HI all. This has two parts.

This data is pulled down in a group format. I have given 1 line under each category for this scenario. It has merged cells as well. I have expanded the grouping from row 8 down. Columns A-K are merged cells. I would think auto fit and deleting of columns would come first then extract what's left would be easier but whichever order works best is fine.

1. Need to extract each location to it's own workbook (locations all have cutomer group at the end of their names. Everything under a location goes with that location until the next location is listed, and
2. auto fit columns and delete columns N,P,Q,R,T so leaving O,Q,S,U.

Thank you for your help.

Customer Dump.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1		Run Date: 5/4/2024 1:44:53 PM											Page #: 1
2
3						Requested Ship Date Range: x/xx/xxxx-x/xx/xxxx
4
5
6
7	Item #		External Item #		Pack Size		Item Desc				Type	Item Group		Order Qty Case	Unit or LB Ordered	Ship Qty Case	Unit or LB Ship	Ship Var - Cases	Ship Var - Unit/Lbs	Case Fill %	Unit or LB Fill Rate
8	ABC Location 1 Customer Group													8,686	23,386	8,604	23,256	82	130	99.06%	99.44%
9	Deli													6,186	6,186	6,152	6,152	34	34	99.45%	99.45%
10	XXX		XXXX		XXXOZ		XXXX				Deli	FG-ENT		169	169	169	169	0	0	100.00%	100.00%
11	Produce													2,500	17,200	2,452	17,104	48	96	98.08%	99.44%
12	ABC Location 2 Customer Group													5,822	19,186	5,756	19,046	66	140	98.87%	99.27%
13	Deli													3,674	3,674	3,674	3,674	0	0	100.00%	100.00%
14	Produce													2,148	15,512	2,082	15,372	66	140	96.93%	99.10%
15	XXX		XXXX		XXXOZ		XXXX				Produce	FG-MAP		36	216	36	216	0	0	100.00%	100.00%
16	DEF Location 1 Customer Group													11,265	29,169	11,217	29,073	48	96	99.57%	99.67%
17	Deli													8,397	8,397	8,397	8,397	0	0	100.00%	100.00%
18	XXX		XXXX		XXXOZ		XXXX				Deli	FG-GRNSAL		59	59	59	59	0	0	100.00%	100.00%
19	Produce													2,868	20,772	2,820	20,676	48	96	98.33%	99.54%
20	XXX		XXXX		XXXOZ		XXXX				Produce	FG-VEG		36	216	36	216	0	0	100.00%	100.00%
21	DEF Location 2 Customer Group													17,703	37,107	17,379	36,651	324	456	98.17%	98.77%
22	Deli													14,463	14,463	14,271	14,271	192	192	98.67%	98.67%
23	XXX		XXXX		XXXOZ		XXXX				Deli	FG-GRNSAL		111	111	105	105	6	6	94.59%	94.59%
24	Produce													3,240	22,644	3,108	22,380	132	264	95.93%	98.83%
25	Report Total													43,476	108,848	42,956	108,026	520	822	98.80%	99.24%
CustomerFillRateBySKU_V2

 

[Burrgogi]

I noticed that column A did not look right after the locations were split off into their own separate workbooks. Do you have wrap text enabled in column A where those Customer groups are located?

If so, the following revised code might work better for autofit.

Sub CreateWorkbooks_v2_A()
    Application.ScreenUpdating = False
    Dim lRow As Long, fnd As Range, fnd2 As Range, sAddr As String, srcWS As Worksheet
    Set srcWS = Sheets("CustomerFillRateBySKU_V2")
    With ActiveWorksheet
        Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).WrapText = False
    End With
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set fnd = .Range("A:A").Find("Location", LookIn:=xlValues, LookAt:=xlPart)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                Set fnd2 = .Range("A" & fnd.Row + 1 & ":A" & lRow - 1).Find("Location", LookIn:=xlValues, LookAt:=xlPart)
                If Not fnd2 Is Nothing Then
                    Workbooks.Add
                    Application.Union(.Range("A7"), .Range("H7"), .Range("J7"), .Range("L7"), .Range("N7")).Copy Range("A1")
                    Application.Union(.Range("A" & fnd.Row & ":A" & fnd2.Row - 1), .Range("H" & fnd.Row & ":H" & fnd2.Row - 1), .Range("J" & fnd.Row & ":J" & fnd2.Row - 1), .Range("L" & fnd.Row & ":L" & fnd2.Row - 1), .Range("N" & fnd.Row & ":N" & fnd2.Row - 1)).Copy Range("A2")
                    Columns.AutoFit
                    Rows(1).AutoFit
                    ActiveSheet.Name = Trim(Split(.Range("A" & fnd.Row), "Customer")(0))
                Else
                    Workbooks.Add
                    Application.Union(.Range("A7"), .Range("H7"), .Range("J7"), .Range("L7"), .Range("N7")).Copy Range("A1")
                    Application.Union(.Range("A" & fnd.Row & ":A" & lRow - 1), .Range("H" & fnd.Row & ":H" & lRow - 1), .Range("J" & fnd.Row & ":J" & lRow - 1), .Range("L" & fnd.Row & ":L" & lRow - 1), .Range("N" & fnd.Row & ":N" & lRow - 1)).Copy Range("A2")
                    Columns.AutoFit
                    Columns("B:B").ColumnWidth = 8.86
                    Rows(1).AutoFit
                    ActiveSheet.Name = Trim(Split(.Range("A" & fnd.Row), "Customer")(0))
                End If
                Set fnd = .Range("A:A").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    End With
End Sub

 

[Alex Blakenburg]

This assumes the layout in Post #1 is correct ie heading row is on row 7 and the sheet has merged cells.
It is not as compact as the other suggestions put forward but should do what you want.
It will save the created workbooks in the same folder as the workbook containing the code.
It uses a temporary workbook in which to unmerge cells and remove columns.

Sub CreateWorkbooks_Alternative()

    Dim srcWB As Workbook, unmergeWB As Workbook, newWB As Workbook
    Dim srcWS As Worksheet, unmergeWS As Worksheet, newWS As Worksheet
    Dim sFldr As String
    Dim unmergeRng As Range, unmergeArr As Variant
    Dim strFind As String
    Dim SectName As String
    Dim lRow As Long, lcol As Long, lRowSectStart As Long, lRowSectEnd As Long
    Dim hdgRow As Long
    Dim i As Long
      
    Application.ScreenUpdating = False
    strFind = "Customer Group"
    Set srcWB = ThisWorkbook
    Set srcWS = srcWB.Sheets("CustomerFillRateBySKU_V2")            ' <--- Change this as required
    sFldr = srcWB.Path                                              ' <--- Change this as required
    If Right(sFldr, 1) <> Application.PathSeparator Then sFldr = sFldr & Application.PathSeparator
    
    ' Create a temporary workbook in which to unmerge the cells and remove unwanted columns
    srcWS.Copy
    Set unmergeWB = ActiveWorkbook
    Set unmergeWS = unmergeWB.ActiveSheet
    With unmergeWS
        hdgRow = 7
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set unmergeRng = .Range("A1:U" & lRow)
        unmergeRng.WrapText = False
        unmergeRng.MergeCells = False
        ' Move headings to the left - currently in blank columns to be deleted
        .Range("B1:U4").Copy Destination:=.Range("B1:U4").Offset(, -1)
        ' Delete blank and columns not required
        .Range("b1,d1,f1,h1:j1,m1,n1,p1,r1,t1").EntireColumn.Delete     ' <--- Change this as required
        lcol = .Cells(hdgRow, Columns.Count).End(xlToLeft).Column
        Set unmergeRng = .Range("A1", .Cells(lRow, lcol))
        unmergeRng.Offset(6).Columns.AutoFit
        unmergeArr = unmergeRng.Columns(1)
    End With
    
    ' Create a workbook for each section
    For i = hdgRow + 1 To lRow
        If InStr(1, unmergeArr(i, 1), strFind, vbTextCompare) > 0 _
            And lRowSectStart = 0 Then
                lRowSectStart = i
        ElseIf InStr(1, unmergeArr(i, 1), strFind, vbTextCompare) > 0 Or i = lRow Then
            lRowSectEnd = i - 1
            SectName = Replace(unmergeArr(lRowSectStart, 1), " " & strFind, "")
            ' Create new workbook
            Set newWB = Workbooks.Add(xlWBATWorksheet)
            Set newWS = newWB.Worksheets(1)
            ' Copy headings
            unmergeRng.Resize(hdgRow).Copy Destination:=newWS.Range("A1")
            ' Copy SectStart to End
            With unmergeWS
                .Range(.Cells(lRowSectStart, 1), .Cells(lRowSectEnd, lcol)).Copy _
                    Destination:=newWS.Range("A" & hdgRow + 1)
                .Range(.Cells(lRowSectStart, 1), .Cells(lRowSectEnd, lcol)).Copy
                    newWS.Range("A" & hdgRow + 1).PasteSpecial Paste:=xlPasteColumnWidths
                newWS.Name = SectName
                
                lRowSectStart = i
            End With
            newWS.Range("A" & hdgRow + 1).Select
            newWB.SaveAs Filename:=sFldr & SectName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            newWB.Close
        End If
    Next i
    
    Application.DisplayAlerts = False
    unmergeWB.Close savechanges:=False
    Application.DisplayAlerts = True
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
 
End Sub