VBA coding - loop Copy visible (filter) cell from Other Sheet

Question

i am new in VBA and i am blocked on my VBA code. what i am trying to do : On my database, inside the colmun M:M, if each cell from column M:M who contain "B1", it copy the line from the Sheet "Database" into another sheet ("Work"), make a filter on the Sheet ("Alloc") on the word "B1" and copy filtered cells from Sheet ("Alloc") to the Sheet ("work")

Please find my code :

    Dim r As Range
    Dim rw As Long, Cell As Range
    
    
    For Each Cell In Sheets("Database").Range("M:M")
    rw = Cell.Row
     If UCase(Cell.Value) Like UCase("*B1*") Then
      Cell.EntireRow.Copy
      
    Sheets("Work").Select
    Range("A1048576").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial xlPasteValues
    
Sheets("Alloc").Select
      Rows("1:1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$H$10000").AutoFilter Field:=1, Criteria1:= _
            "B1"

        Set r = Sheets("Alloc").Range("B2")
        Do While r.Value <> ""
          Range("N1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
        Loop

         Set r = Sheets("Alloc").Range("C2")
        Do While r.Value <> ""
          Range("O1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop

           Set r = Sheets("Alloc").Range("D2")
        Do While r.Value <> ""
          Range("P1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop
   
           Set r = Sheets("Alloc").Range("E2")
        Do While r.Value <> ""
          Range("Q1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop
     
    Sheets("Alloc").Select
      Rows("1:1").Select
        Selection.AutoFilter
    
    
     End If
    
     Next

My code is working, the only issue it's copy also data in sheet ("alloc") who are also fileted do you know how i can take only the filtered data from the sheet ("Alloc") into the sheet("work") ?

Thanks a lot for your help

Admin · Answer

The following is based on your description of the problem - rather than on your code. Please try the following & let me know how it goes. Assumes both the Database and Alloc sheets have headings in row 1 starting in A1 and contiguous data.

Option Explicit
Sub CopyData()

Dim ws1 As Worksheet: Set ws1 = Sheets("Database")
Dim ws2 As Worksheet: Set ws2 = Sheets("Alloc")
Dim ws3 As Worksheet: Set ws3 = Sheets("work")

Dim PasteRow As Long

PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1

With ws1.Cells(1, 1).CurrentRegion
    .AutoFilter 13, "*B1*", 7
    .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(PasteRow, 1)
    .AutoFilter
End With

PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1

With ws2.Cells(1, 1).CurrentRegion
    .AutoFilter 1, "B1", 7
    .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(PasteRow, 1)
    .AutoFilter
End With

End Sub

VBA coding - loop Copy visible (filter) cell from Other Sheet

1 Answers