Error at attempt to copy data from external workbook with several worksheets to another workbook

Question

The problem: I am trying to copy data from one workbook to another.

Lets say I have a workbook (called DATA) with several worksheets filled with data. Each column of data has a unique heading (all headings on the same row).

On the other hand I have another workbook (called REPORT) with one worksheet that contains only the heading of the data (in one row). They are not in the same order as in DATA workbook. For example I have 3 headings in REPORT worksheet that can be found in different worksheets in DATA workbook.

I need to loop through all the worksheets in the DATA workbook and copy paste the whole column to the REPORT worksheet when the same heading is found.

This image may help to understand. Explanation

My first attempt:

Dim MyFile As String
Dim ws As Worksheet

''Workbook that contains one worksheet with all the headings ONLY NO DATA
Dim TargetWS As Worksheet
Set TargetWS = ActiveSheet
Dim TargetHeader As Range

''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")

''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Dim SourceWB As Workbook
Set SourceWB = Workbooks("Source.xlsx")
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range

''Stores the col of the found value and the last row of data in that col
Dim RealLastRow As Long
Dim SourceCol As Integer

''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
    ws.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)

            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                    SourceCol)).Copy
                    TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next
Next

I am getting an error of Application-defined or object-defined error Run-time 1004. Is there something wrong with my logic/syntax..?

Please help I am so bad in VBA.

Thanks in advance!

user3598756 user3598756 · Accepted Answer · 2016-05-01T07:44:40

your last edited code works

but you're making unnecessary checks and I'd suggest you to loop through each sheet header and check if it exists in TargetHeader range to possibly subsequently copy its column to SourceWB

furthermore you may want to have your code more robust and check for actual wanted workbooks/worksheets existence before attempting to set variables to them

like follows:

Option Explicit

Sub main()

Dim SourceWB As Workbook
Dim ws As Worksheet, TargetWS  As Worksheet
Dim TargetHeader As Range, cell As Range, SourceCell As Range
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1

''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Set SourceWB = GetWb("Source.xlsx")
If SourceWB Is Nothing Then Exit Sub

''Workbook that contains one worksheet with all the headings ONLY NO DATA
'Set TargetWS = ActiveSheet
Set TargetWS = GetWs("REPORT") 'it will get the first worksheet (if any) in "REPORT" workbook (if open)
If TargetWS Is Nothing Then Exit Sub

''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")

''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
    For Each cell In ws.Rows(SourceHeaderRow).SpecialCells(xlCellTypeConstants, xlTextValues)
        Set SourceCell = TargetHeader.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not SourceCell Is Nothing Then
            Range(cell.Offset(1), ws.Cells(ws.Rows.Count, cell.Column).End(xlUp)).Copy
            SourceCell.Offset(1).PasteSpecial xlPasteValues
        End If
    Next
Next
End Sub


Function GetWb(wbName As String) As Workbook
    On Error Resume Next
    Set GetWb = Workbooks(wbName)
    On Error GoTo 0
    If GetWb Is Nothing Then MsgBox "Sorry, the workbook '" & wbName & "' isn't open" & vbCrLf & vbCrLf & "Please open it and run the macro again"
End Function


Function GetWs(wbName As String, Optional wsName As Variant) As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = GetWb(wbName)
    If wb Is Nothing Then Exit Function

    On Error Resume Next
    If IsMissing(wsName) Then
        Set GetWs = wb.Worksheets(1) ' if no ws name passed then get the first one
    Else
        Set GetWs = wb.Worksheets(wsName)
    End If
    On Error GoTo 0
    If GetWs Is Nothing Then MsgBox "Sorry, the worksheet '" & wsName & "0 isn't in '" & wb.Name & "'" & vbCrLf & vbCrLf & "Please open a valid workbook and run the macro again"
End Function

Error at attempt to copy data from external workbook with several worksheets to another workbook

1 Answers