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

[archerrc]

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:

Sub Copypaste()


  ' Filter original data sheet by year and month
    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