copying specific columns from one excel sheet to another

Question

I have a worksheet in excel wich needs only specific data copied to another worksheet.

The destination sheet does have more columns than are actually needed, so I had to create a macro which copies only the specified data from the source sheet to the destination sheet.

The thing is, that it does not copy any column and says that it is either an object or application problem.

Here's the code:

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

It's not exactly an error, just that the code does not copy the specific data, or anything for that matter. — Yanis Pizarro

Ahmed Raafat Ahmed Raafat · Accepted Answer · 2020-09-08T07:39:37

I had the same issue of yours and I fixed by setting the right column index

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

copying specific columns from one excel sheet to another

1 Answers