Filter data and copy visible cells based on criteria

Maybe :

Sub Test()
  Dim arrRng(1 To 3) As Range, rng As Range, i As Long

  Application.ScreenUpdating = False

  For i = 1 To UBound(arrRng)
      Set arrRng(i) = Worksheets("0" & i & "A").Range("C6")
      arrRng(i).Resize(1000).ClearContents
  Next i

  With Sheets("Data")
    .AutoFilterMode = False
    With .Range("B1").CurrentRegion
      .AutoFilter field:=3, Criteria1:=Parent.Range("I1").Value
      .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible).Copy arrRng(1)
    End With
    .AutoFilterMode = False
  End With

  For i = 1 To (UBound(arrRng) - 1)
      With arrRng(i).Offset(29).Resize(1000)
        If Not IsEmpty(.Cells(1)) Then
           .Copy arrRng(i + 1)
           .ClearContents
        Else
           Exit For
        End If
      End With
  Next i

  Application.ScreenUpdating = True
End Sub

Originally Posted by YasserKhalil

Thanks a lot for this great and swift help my best friend

In fact, the new requests are coming in swift mode too

I need to add lines at first of the code that show all the sheets (01A - 01B - 02A - 02B - 03A - 03B)
then at the end of the code to hide the sheets that doesn't receive data

It is easier the opposite way, first the code hiding all sheets (as the same time with clearcontents job), and then do the copy paste job, and finally showing the sheets which have data on them.

May I have alert message if the number of results exceeded the number of sheets which will receive data
....
Thanks a lot ..(Bear me in this thread ..as I have many points)

Done.
BTW, you....... are a bear ?

Sub Test()
  Dim arrRng(1 To 3) As Range, rng As Range, i As Long, total As Long

  Application.ScreenUpdating = False

  For i = 1 To UBound(arrRng)
      Set arrRng(i) = Worksheets("0" & i & "A").Range("C6")
      arrRng(i).Resize(1000).ClearContents
      arrRng(i).Parent.Visible = xlSheetVeryHidden
      Sheets(Replace(arrRng(i).Parent.Name, "A", "B")).Visible = xlSheetVeryHidden
  Next i

  With Sheets("Data")
    .AutoFilterMode = False
    With .Range("B1").CurrentRegion
      .AutoFilter field:=3, Criteria1:=.Parent.Range("I1").Value
      With .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible)
        total = .Count
        .Copy arrRng(1)
      End With
    End With
    .AutoFilterMode = False
  End With

  If Not IsEmpty(arrRng(1)) Then
     arrRng(1).Parent.Visible = xlSheetVisible
     Sheets(Replace(arrRng(1).Parent.Name, "A", "B")).Visible = xlSheetVisible

     For i = 1 To (UBound(arrRng) - 1)
         With arrRng(i).Offset(29).Resize(1000)
           If Not IsEmpty(.Cells(1)) Then
              .Copy arrRng(i + 1)
              .ClearContents
              arrRng(i + 1).Parent.Visible = xlSheetVisible
              Sheets(Replace(arrRng(i + 1).Parent.Name, "A", "B")).Visible = xlSheetVisible
           Else
              Exit For
           End If
         End With
     Next i
     
     If total > 29 * UBound(arrRng) Then MsgBox "Not enough sheets to divide data properly"
  End If

  Application.ScreenUpdating = True
End Sub

Originally Posted by YasserKhalil

Thanks a lot for this wonderful help ..
By the way how can I say (Bear with me ..) I mean ...

You are welcome.
Yes, I know
It has been a while since I am being involved in some of your threads. I just made a joke to make it not too boring.
The bear, I mean, like the grizzly bear, polar bear, ....

-----

One way is to save the filtered rows of AutoFilter to a variable (in my code below it is called filteredRows), and then you can use this var as many time as needed, together with intersect method, to get intersection area of expected columns.

Sub Test()
  Dim arrRngA(1 To 3) As Range, arrRngB(1 To 3) As Range, filteredRows As Range
  Dim i As Long, total As Long

  Application.ScreenUpdating = False

  For i = 1 To UBound(arrRngA)
      Set arrRngA(i) = Worksheets("0" & i & "A").Range("C6")
      Set arrRngB(i) = Worksheets("0" & i & "B").Range("AE6")
      arrRngA(i).Resize(1000, 10).ClearContents  '.Resize(1000, 10) = 1000 rows x 10 columns (C:L)
      arrRngB(i).Resize(1000).ClearContents
      arrRngA(i).Parent.Visible = xlSheetVeryHidden
      arrRngB(i).Parent.Visible = xlSheetVeryHidden
  Next i

  With Sheets("Data")
    .AutoFilterMode = False
     With .Range("B1").CurrentRegion
       .AutoFilter field:=3, Criteria1:=.Parent.Range("I1").Value
        With .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible)
          total = .Count
          Set filteredRows = .EntireRow
        End With
     End With
    .AutoFilterMode = False
  
    If total >= 2 Then
       arrRngA(1).Parent.Visible = xlSheetVisible
       Intersect(filteredRows, Sheet1.Columns("B")).Copy arrRngA(1)
       Intersect(filteredRows, Sheet1.Columns("V:X")).Copy arrRngA(1).Offset(0, 1)
       Intersect(filteredRows, Sheet1.Columns("P:U")).Copy arrRngA(1).Offset(0, 4)

       arrRngB(1).Parent.Visible = xlSheetVisible
       Intersect(filteredRows, Sheet1.Columns("K")).Copy arrRngB(1)
    Else
       Exit Sub
    End If
  End With

  For i = 1 To (UBound(arrRngA) - 1)
      With arrRngA(i).Offset(29).Resize(1000, 10)
        If Not IsEmpty(.Cells(1)) Then
           .Copy arrRngA(i + 1)
           .ClearContents
           arrRngA(i + 1).Parent.Visible = xlSheetVisible
        Else
           Exit For
        End If
      End With
      With arrRngB(i).Offset(29).Resize(1000)
        .Copy arrRngB(i + 1)
        .ClearContents
        arrRngB(i + 1).Parent.Visible = xlSheetVisible
      End With
  Next i

  If total > 29 * UBound(arrRngA) Then MsgBox "Not enough sheets to divide data properly"
  Application.ScreenUpdating = True
End Sub

As your post in #9, the layout has been changed, i.e. :
- Data now start from column A (previously column B), so what field to be AutoFiltered now ?
- Previously the criteria is taken from cell I1, now column I is used as data area, where is the criteria cell now ?

But the principal is exactly the same with the code in #10, you just need to adjust some area.
If you have any trouble, please upload the workbook of final layout.

You are welcome.
And about we are of the same kind, I didn't see it coming


Regards