Copy/Paste filtered data from one sheet to another with only matched column headings

Hi everyone,

Really appreciate it if you could take a look at this. I have been scratching my head trying to figure out what I did wrong here.

A simple example of what i am trying to do is: I have a data sheet that has Name/Description/Year information (the source sheet). The second sheet only has a heading "Name" on it (the destination sheet).

The macro should filter the data by year (say only for the year 2015). Copy and paste only "Name" related data into the column on second sheet.

However my macro only copy and paste the last record of the filtered range. Could anyone please point out what I did wrong? Thank you very much.

AC

Code is here and i also attach the file:

    Application.ScreenUpdating = False
            
    Dim rng As Range, lcount As Long, lrow As Variant
    Dim RowArray() As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Lastrow As Long
    Dim Found As Range
    Dim i As Variant, j As Variant
    
    Set ws1 = Sheets("Destination")
    Set ws2 = Sheets("Source")
    
    ws2.Activate
    ActiveSheet.AutoFilterMode = False
    Range("A2").Select
    
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter
            
    With Selection
         .AutoFilter
         .AutoFilter Field:=3, Criteria1:=2015
         .Select
         For Each rng In .SpecialCells(xlCellTypeVisible).Areas
         lcount = lcount + rng.Rows.Count
         lrow = lrow + 1
         ReDim Preserve RowArray(1 To lrow)
         RowArray(lrow) = rng.Row
         Next rng
    End With
           
    Lastrow = ws1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
               
    For i = 1 To ws2.Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 1 To lcount - 1
    For Each lrow In RowArray()
    
       If Not IsEmpty(ws2.Cells(1, i)) Then
           Set Found = ws1.Range("1:1").Find(ws2.Cells(1, i), , , xlWhole, xlByColumns, xlNext, False)
       
           If Not Found Is Nothing Then
               ws1.Cells(Lastrow, Found.Column).Offset(j, 0).Value = ws2.Cells(lrow, i).Value
           End If
           
       End If
    
     Next lrow
     Next j
     Next i


    Application.ScreenUpdating = True


    ws2.AutoFilterMode = False
    
    End Sub

I am not sure if this helps

Sub filterme()
Application.ScreenUpdating = False
With Sheets("Source")
    .AutoFilterMode = False
    With .Range("A1:C" & .Cells(Rows.Count, "A").End(xlUp).Row)
        .AutoFilter Field:=3, Criteria1:=2015
        .SpecialCells(xlCellTypeVisible).Range("A2:A" & Rows.Count).Copy
        Sheets("Destination").Range("B2").PasteSpecial Paste:=xlPasteValues
        .AutoFilter
    End With
End With
Application.ScreenUpdating = True
End Sub

Thanks AB33. This would work for this sample file. But the real file I am working on is a lot bigger and more complicated (has about 60 headings to match on the destination sheet). And the source file will be updated every day. That's why I am trying to figure out a way to easily match row/column dynamically then copy/paste data. Does that make any sense?

Thank you!

Arc,
Sorry!
I have not read your request in details. I saw the heading only.
You probably need to modify this line

For Each rng In .SpecialCells(xlCellTypeVisible).Areas

It is looking in to the whole areas as opposed to column A only

Thanks AB33,

I changed it to For Each rng In Range ("A:A").SpecialCells(xlCellTypeVisible).Areas but it didn't seem to work.

Any other suggestions?

Sincerely appreciate your time and help.

AC

I used this line

 .SpecialCells(xlCellTypeVisible).Range("A2:A" & Rows.Count).Copy