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

Hi,

Using array (as alternative to my Avenger team who use AutoFilter) :

Sub Test()
  Dim arrData, arrSheet, i As Long, j As Long

  ReDim arrSheet(1 To Worksheets.Count, 1 To 2)
  With Sheets("Data")
    For i = 1 To Worksheets.Count
        arrSheet(i, 1) = Worksheets(i).Name                             'Set sheet's name
        Set arrSheet(i, 2) = Intersect(.Rows("1:5"), .Columns("A:G"))   'Set header
    Next i
    arrData = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    For i = 6 To UBound(arrData, 1)
        For j = 1 To UBound(arrSheet, 1)
            If arrSheet(j, 1) = arrData(i, 7) Then
               Set arrSheet(j, 2) = Union(arrSheet(j, 2), Intersect(.Rows(i), Columns("A:G")))  'For matched item, union this row with previous value
               Exit For
            End If
        Next j
    Next i
    For i = 1 To UBound(arrSheet, 1)
        If arrSheet(i, 1) <> "Data" Then
           arrSheet(i, 2).Copy Worksheets(arrSheet(i, 1)).Range("A1")  'Copy each item to corresponding sheet
        End If
    Next i
  End With
End Sub

Regards

You are welcome, thanks for the reps. Don't worry, we are always ready to eradicate crimes.

Here is the code to exclude blank sheets :

Sub Test()
  Dim arrData, arrSheet, i As Long, j As Long, rngHeader As Range

  ReDim arrSheet(1 To Worksheets.Count, 1 To 2)
  With Sheets("Data")
    Set rngHeader = Intersect(.Rows("1:5"), .Columns("A:G"))
    For i = 1 To Worksheets.Count
        arrSheet(i, 1) = Worksheets(i).Name   'Set sheet's name
        Set arrSheet(i, 2) = rngHeader        'Set header
    Next i
    arrData = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    For i = 6 To UBound(arrData, 1)
        For j = 1 To UBound(arrSheet, 1)
            If arrSheet(j, 1) = arrData(i, 7) Then
               Set arrSheet(j, 2) = Union(arrSheet(j, 2), Intersect(.Rows(i), Columns("A:G")))  'For matched item, union this row with previous value
               Exit For
            End If
        Next j
    Next i
    For i = 1 To UBound(arrSheet, 1)
        If arrSheet(i, 2).Address <> rngHeader.Address Then
           arrSheet(i, 2).Copy Worksheets(arrSheet(i, 1)).Range("A1")  'Copy to corresponding sheet
        End If
    Next i
  End With
End Sub

Regards