问题描述:

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!

网友答案:

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
相关阅读:
Top