копирование указанных c столбцов из одного листа Excel в другой

Question

У меня есть лист в Excel, для которого нужны только указанные c данные, скопированные на другой лист.

На целевом листе больше столбцов, чем на самом деле необходимо, поэтому мне пришлось создать макрос, который копирует только указанные данные с исходного листа на целевой лист.

Дело в том, что он не копирует ни один столбец и говорит, что это проблема объекта или приложения.

Вот код :

Option Explicit

Function GetHeadersDict() As Scripting.Dictionary

Dim result As Scripting.Dictionary

    Set result = New Scripting.Dictionary

    With result

        .Add "ATA", False
        .Add "PART NO", False
        .Add "SERIAL NO", False
        .Add "DESCRIPTION", False
        .Add "POSITION", False
        .Add "DUE DATE", False
        .Add "TSN", False
        .Add "CSN", False
        .Add "REMARKS", False


    End With

    Set GetHeadersDict = result

End Function

Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range

    Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)

End Function

Sub clearDataSheet2()

Sheets("Data").Range("A1").CurrentRegion.Offset(1).ClearContents

End Sub

Sub copyColumnData()

On Error GoTo ErrorMessage

Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Hoja2")
    Set ws2 = ThisWorkbook.Sheets("Data")

    clearDataSheet2

Dim numRowsToCopy As Long

    numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row - 1
    MsgBox "The number of rows to copy is " & numRowsToCopy

Dim destRowOffset As Long

    destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
    MsgBox "The next Blank row is " & destRowOffset

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim source As Range
Dim dest As Range

Dim headersDict As Scripting.Dictionary

    Set headersDict = GetHeadersDict()

        For Each dictKey In headersDict
            header = dictKey
            If headersDict.Item(header) = False Then
                Set source = FindHeaderRange(ws1, header)
            If Not (source Is Nothing) Then
                Set dest = FindHeaderRange(ws2, header)
                    If Not (dest Is Nothing) Then
                        headersDict.Item(header) = True
                        For numColumnsToCopy = 1 To headersDict.Count
                            MsgBox numColumnsToCopy
                            If source.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
                                headersDict.Item(source.Offset(ColumnOffset:=numColumnsToCopy).Value) = True
                            Else
                                Exit For
                            End If

                        Next numColumnsToCopy

                        source.Offset(RowOffset:=1).Resize(RowSIze:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
                            dest.Offset(RowOffset:=destRowOffset)
                    End If
                 End If
            End If

        Next dictKey

Dim msg As String

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            msg = msg & vbNewLine & header
        End If
    Next dictKey

ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    If msg <> "" Then
        MsgBox "The following headers were not copied: " & vbNewLine & msg
    End If
Exit Sub
ErrorMessage:
        MsgBox "An error has occured: " & Err.Description
        Resume ExitSub

End Sub