Transfer data based on values in range to related sheets

Hi,

Consider unmerging row 4 and 5. With the current structure, the procedure below only copy row 4 as header.

Try,

Sub test()

    Dim wsIn As Worksheet: Set wsIn = ThisWorkbook.Sheets("Data")
    Dim ws As Worksheet, rng As Range

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> wsIn.Name Then
            With wsIn.Range("A4").CurrentRegion
                wsIn.AutoFilterMode = False
                .AutoFilter 7, ws.Name
                On Error Resume Next
                Set rng = Intersect(.Offset(2), wsIn.AutoFilter.Range.SpecialCells(12))
                On Error GoTo 0
                If Not rng Is Nothing Then
                    wsIn.Range("A4:G4").Copy ws.Range("A1")    'header
                    rng.Copy ws.Range("A2")    'rest of data
                End If
                wsIn.AutoFilterMode = False
            End With
        End If
    Next

End Sub

Cheers,
berlan