VBA to Split Data From an Existing Table into Another Single Worksheet with Header for Each Section

[aaumdamm]

Hello All,

I am studying Excel's newer versions, especially the VBA code on which I used to work a while back. A need has come up again to write a small VBA. I was able to find the references but those ones are giving me the solution that splits the data and copies it into multiple worksheets. My requirement is to split the data in a given worksheet by a filter and then paste all of them to another single worksheet only with the header for each section.

As an example, I have a worksheet (DataSource) with the table in cells A4:D100. A1:D2 have the other header information while A3:D3 has the table headers. I would like to filter by column D and paste the output of the filtered data along with the cell format/width from this DataSource to a new worksheet (DataTarget). Each section to be copied to DataTarget sheet will have the data filtered in column D along with the 3 header rows (A1:D3) above each section. I have this reference code from HippieHacker from quite a while back, which I was able to reference and it works well. But instead of pasting each section with the header to "Multiple worksheets", I need to paste it in the same DataTarget worksheet and I am struggling to get it up and running.

Appreciate any help and guidance.

Sub DataSplitWithHeader()
Set asheet = ActiveSheet
lastrow = asheet.Range("D" & Rows.Count).End(xlUp).Row
myarray = uniqueValues(asheet.Range("D4:D" & lastrow))

For i = LBound(myarray) To UBound(myarray)
 Sheets.Add.Name = myarray(i)
 asheet.Range("A3:D" & lastrow).AutoFilter Field:=24, Criteria1:=myarray(i)
 asheet.Range("A1:D" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
        Sheets(myarray(i)).Range("A1")
 asheet.Range("A3:D" & lastrow).AutoFilter
Next i
End Sub

Private Function uniqueValues(InputRange As Range)
    Dim cell As Range
    Dim tempList As Variant: tempList = ""
    For Each cell In InputRange
        If cell.Value <> "" Then
            If InStr(1, tempList, cell.Value) = 0 Then
                If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
            End If
        End If
    Next cell
    uniqueValues = Split(tempList, "|")
End Function

 

[John_w]

Try this macro. If I've understood you correctly, it splits the first table on the "DataSource" sheet by column D and outputs the results on the "DataTarget" sheet, with the 2 rows of header cells above each table results section. It preserves the column widths and rows heights of the 2 rows of header cells and the table header format, header and data row heights, table style (e.g. banded rows) and cell formats. There is 1 blank row gap between sections.

Public Sub Split_Table_To_Sections_In_Other_Sheet()

    Dim headerCells As Range
    Dim sourceTable As ListObject
    Dim targetDest As Range
    Dim Dvalue As Variant
    Dim colDdict As Object
    Dim numRows As Long
    Dim AutoFilterIsOn As Boolean
    
    With ThisWorkbook.Worksheets("DataSource")
        Set headerCells = .Range("A1:D2")
        Set sourceTable = .ListObjects(1)
    End With
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("DataTarget")
        .Cells.Delete
        Set targetDest = .Range("A1")
    End With
    
    AutoFilterIsOn = sourceTable.ShowAutoFilter
    If AutoFilterIsOn Then sourceTable.AutoFilter.ShowAllData
        
    'Create dictionary of different column D values
    
    Set colDdict = CreateObject("Scripting.Dictionary")
    For Each Dvalue In sourceTable.ListColumns(4).DataBodyRange
        colDdict(CStr(Dvalue)) = 1
    Next
       
    'Loop through each different column D value
    
    For Each Dvalue In colDdict.Keys
        
        'Copy header cells and paste to target destination
        
        With targetDest
            
            headerCells.EntireRow.Copy
            
            'Use Format Painter for row heights
            .Resize(headerCells.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            'Column widths, formats and cell values
            .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Set targetDest = .Offset(headerCells.Rows.Count)
            
        End With
        
        'AutoFilter column 4 of table by this column D value
        
        sourceTable.Range.AutoFilter Field:=sourceTable.ListColumns(4).Index, Criteria1:="=" & Dvalue
        
        'Copy visible cells and paste to target destination
        
        With targetDest
            
            numRows = sourceTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
            
            'Use Format Painter for row heights
            sourceTable.Range.SpecialCells(xlVisible).EntireRow.Copy
            .Resize(numRows).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            'Cell formats and cell values (column widths already done above)
            sourceTable.Range.SpecialCells(xlVisible).Copy
            .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Set targetDest = .Offset(numRows + 1)  '+1 gives 1 blank row gap between sections
        
        End With
    
    Next
    
    Application.CutCopyMode = False
    
    'Restore autofilter on table if it was on
    
    If AutoFilterIsOn Then
        sourceTable.AutoFilter.ShowAllData
    Else
        sourceTable.Range.AutoFilter
    End If
    
    Application.ScreenUpdating = True
    
End Sub