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

You got half way there. First filter for your data and then, instead of looping, just copy the visible cells and paste them all at once. No need to loop here — urdearboy
See this solution as an example. There are many examples you can find on this site. This is just the first one that popped up after searching 'filter and copy visible cells' — urdearboy

Unknown Unknown · Accepted Answer · 2021-03-06T00:48:05

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