How can I split a sheet into multiple sheets and copy column widths?

Question

I've got a working Excel VBA macro that splits one worksheet into multiple based on the values in a particular column. However, I can't figure out how to modify two things about this macro.

I'd like to add a text string to the name of each sheet. (Instead of naming the sheet with just the numeric value it's splitting on, I'd like it to read "<text> value"
I need to copy column widths onto the new sheets. This macro currently copies formatting correctly, but I'm losing column widths.

Sub Copy_Data()
 Dim r As Range, LastRow As Long, ws As Worksheet
 Dim LastRow1 As Long, MyColumn As String
 Dim src As Worksheet
  MyColumn = "C"
  Set src = Sheets("Sheet1")
 LastRow = src.Cells(Cells.Rows.Count, MyColumn).End(xlUp).Row
 For Each r In src.Range(MyColumn & "4:" & MyColumn & LastRow)
         On Error Resume Next
         Set ws = Sheets(CStr(r.Value))
         On Error GoTo 0
         If ws Is Nothing Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
             'This row adds a header from the source sheet
             '1:3 selects the rows to copy
             src.Rows("1:3").Copy ActiveSheet.Range("A1")
             LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, MyColumn).End(xlUp).Row
             src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
             Set ws = Nothing
         Else
             LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, MyColumn).End(xlUp).Row
             src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
             Set ws = Nothing
         End If

 Next r
 End Sub

score 1 · Accepted Answer · answered Dec 09 '19 at 15:04

This should give you the 2 things requested. I've added some commentary to help you follow what's happening.

Sub Copy_Data()
 Dim r As Range, LastRow As Long, ws As Worksheet
 Dim LastRow1 As Long, MyColumn As String
 Dim src As Worksheet

 MyColumn = "C"

 MyLabel = "<text>"

 Set src = Sheets("Sheet1")
 ' find last row
 LastRow = src.Cells(src.Cells.Rows.Count, MyColumn).End(xlUp).Row
 ' loop through each cell in column from row 4 down to last row
 For Each r In src.Range(MyColumn & "4:" & MyColumn & LastRow)
    On Error Resume Next
    Set ws = Sheets(MyLabel & CStr(r.Value))
    On Error GoTo 0
    If ws Is Nothing Then
        ' create ws object from new worksheet
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ' copy row 1
        src.Range("1:1").Copy
        ' paste row 1 column widths to destination sheet
        ws.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths
        ' clear clip
        Application.CutCopyMode = False
        ' name ws sheet with label and number
        ws.Name = MyLabel & CStr(r.Value)
        ' copy 3 rows as header
        src.Rows("1:3").Copy ActiveSheet.Range("A1")
    End If
    ' find last row
    LastRow1 = ws.Cells(ws.Cells.Rows.Count, MyColumn).End(xlUp).Row
    ' copy from source to row below lastrow found
    src.Rows(r.Row).Copy ws.Cells(LastRow1 + 1, 1)
    Set ws = Nothing
 Next r

End Sub

As a follow up @CLR, is there a quick/easy/etc. way to apply this macro to all the workbooks in a folder? I have 50-something separate .xlsx files, each of which needs to run this macro, so if I can avoid opening each file and running this macro I'd save lots of time. — Somebody, Dec 09 '19 at 17:44
Yes, that's easy enough to do. It sounds like a new question that you should raise but you should be able to find plenty of answers on here already that will give you the outline. eg. https://stackoverflow.com/questions/14766238 — CLR, Dec 10 '19 at 09:30
That's a great start, thanks! I'll raise a new question if I have trouble getting that going. Thank you for the help! — Somebody, Dec 10 '19 at 12:42

score 0 · Answer 2 · answered Dec 09 '19 at 15:09

The code below will achieve your desired objectives, it will loop through your worksheets using InStr to see if the name of the worksheet contains the given value, the set that worksheet to copy data to, also amended your Paste method to include Values, Formatting, Column Widths, etc...:

Sub Copy_Data()
Dim src As Worksheet, wks As Worksheet, ws As Worksheet
Dim r As Range
Dim LastRow As Long, NextRow As Long

MyColumn = "C"
Set src = ThisWorkbook.Worksheets("Sheet1")
LastRow = src.Cells(Cells.Rows.Count, MyColumn).End(xlUp).Row

For Each r In src.Range(MyColumn & "4:" & MyColumn & LastRow)

    For Each wks In ThisWorkbook.Worksheets
    'loop through worksheets to find one that containt the current value
        If InStr(wks.Name, CStr(r.Value)) > 0 Then
            'check worksheet name contains value
            Set ws = wks
            Exit For
        End If
    Next wks

    If ws Is Nothing Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Text " & CStr(r.Value)
        'amend above this to replace "Text" with whatever value you want.

        'This row adds a header from the source sheet
        '1:3 selects the rows to copy
        src.Rows("1:3").Copy ActiveSheet.Range("A1")
        NextRow = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, MyColumn).End(xlUp).Offset(1, 0).Row
        src.Rows(r.Row).Copy 'Sheets(CStr(r.Value)).Cells(NextRow + 1, 1)
        With Sheets(CStr(r.Value)).Cells(NextRow, 1)
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
        Application.CutCopyMode = False
        End With
        Set ws = Nothing
    Else
        NextRow = ws.Cells(Cells.Rows.Count, MyColumn).End(xlUp).Offset(1, 0).Row
        src.Rows(r.Row).Copy 'Sheets(CStr(r.Value)).Cells(NextRow + 1, 1)
        With ws.Cells(NextRow, 1)
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            Application.CutCopyMode = False
        End With
        Set ws = Nothing
    End If

Next r
End Sub

How can I split a sheet into multiple sheets and copy column widths?

2 Answers2