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 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.

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

 

[Monty]

Hello

After looking at code i think you have to replace the line

Sheets.Add.Name = myarray(i) with Worksheets("DataTarget").Activate.

Here is the modified version of your cod3.

Sub DataSplitWithHeader()
    Dim asheet As Worksheet
    Dim lastrow As Long
    Dim myarray As Variant
    Dim i As Long
    Dim nextRow As Long

    Set asheet = ActiveSheet
    lastrow = asheet.Range("D" & Rows.Count).End(xlUp).Row
    myarray = uniqueValues(asheet.Range("D4:D" & lastrow))
    nextRow = 1 ' Initialize nextRow variable

    For i = LBound(myarray) To UBound(myarray)
        Worksheets("DataTarget").Activate ' Activate DataTarget worksheet
        asheet.Range("A3:D" & lastrow).AutoFilter Field:=4, Criteria1:=myarray(i)
        asheet.Range("A1:D3").Copy ' Copy header rows
        Worksheets("DataTarget").Cells(nextRow, 1).PasteSpecial Paste:=xlPasteAll ' Paste headers
        nextRow = nextRow + 4 ' Increment nextRow by 4 (to leave space for headers)
        asheet.Range("A1:D" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Worksheets("DataTarget").Cells(nextRow, 1)
        nextRow = nextRow + asheet.Range("A1:D" & lastrow).SpecialCells(xlCellTypeVisible).Rows.Count + 1 ' Increment nextRow
        asheet.Range("A3:D" & lastrow).AutoFilter
    Next i
End Sub

Private Function uniqueValues(InputRange As Range) As Variant
    Dim cell As Range
    Dim tempList As String
    Dim uniqueArray() As String
    Dim i As Long

    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
        End If
    Next cell
    uniqueArray = Split(tempList, "|")
    uniqueValues = uniqueArray
End Function

 

[aaumdamm]

Thank you Monty for your time, really clever and logical, yet a simplistic approach!!
It's close and it is now also populating the DataTarget worksheet along with the headers from A1:D3.
Apologies for not mentioning that A1:D2 header information has the formulas. While iterating through the first filter range, it is copying and pasting the formulas. But the subsequent headers (header 2, 3...n) is just pasting both the header lines without the formulas. Any thoughts why this would be so?
Also, when bringing over the sections after the first one, it's shifting and overwriting the rows. However, I am still going through your code and running it to understand it better so that I can writeup a clear and concise explanation of what's happening to make it clear.

 

[Monty]

Try this !

Sub DataSplitWithHeader()
    Dim asheet As Worksheet
    Dim lastrow As Long
    Dim myarray As Variant
    Dim i As Long
    Dim nextRow As Long
    Dim targetSheet As Worksheet

    Set asheet = ActiveSheet
    Set targetSheet = Worksheets("DataTarget")
    lastrow = asheet.Range("D" & Rows.Count).End(xlUp).Row
    myarray = uniqueValues(asheet.Range("D4:D" & lastrow))
    nextRow = 1 ' Initialize nextRow variable

    For i = LBound(myarray) To UBound(myarray)
        asheet.Range("A3:D" & lastrow).AutoFilter Field:=4, Criteria1:=myarray(i)
        asheet.Range("A1:D3").Copy
        targetSheet.Cells(nextRow, 1).PasteSpecial Paste:=xlPasteAll ' Paste header with formulas
        nextRow = nextRow + 3 ' Increment nextRow by 3 for header rows

        Dim visibleRows As Range
        On Error Resume Next
        Set visibleRows = asheet.Range("A1:D" & lastrow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not visibleRows Is Nothing Then
            visibleRows.Copy Destination:=targetSheet.Cells(nextRow, 1)
            nextRow = nextRow + visibleRows.Rows.Count
        End If

        asheet.Range("A3:D" & lastrow).AutoFilter
    Next i
    Application.CutCopyMode = False ' Clear clipboard
End Sub

Private Function uniqueValues(InputRange As Range) As Variant
    Dim cell As Range
    Dim tempList As String
    Dim uniqueArray() As String
    Dim i As Long

    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
        End If
    Next cell
    uniqueArray = Split(tempList, "|")
    uniqueValues = uniqueArray
End Function