copying specific columns from one Excel sheet to another - excel

Question

I have a worksheet in Excel which 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

Answer 1

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