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
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, _
If RealLastRow > SourceHeaderRow Then
Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
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!
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
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
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