Fehler beim Versuch, Daten aus einer externen Arbeitsmappe mit mehreren Arbeitsblättern in eine andere Arbeitsmappe zu kopieren

Question

Das Problem: Ich versuche, Daten von einer Arbeitsmappe in eine andere zu kopieren.

Nehmen wir an, ich habe eine Arbeitsmappe (genannt DATA) mit mehreren Arbeitsblättern mit Daten gefüllt. Jede Datenspalte hat eine eindeutige Überschrift (alle Überschriften in derselben Zeile).

Auf der anderen Seite habe ich eine andere Arbeitsmappe (namens REPORT) mit einem Arbeitsblatt, das nur die Überschrift der Daten (in einer Zeile) enthält. Sie sind nicht in derselben Reihenfolge wie in der Arbeitsmappe DATA. Zum Beispiel habe ich 3 Überschriften in REPORT Arbeitsblatt, die in verschiedenen Arbeitsblättern in der Arbeitsmappe DATA gefunden werden können.

Ich muss alle Arbeitsblätter in der Arbeitsmappe DATA durchlaufen und kopieren Sie die gesamte Spalte in das Arbeitsblatt Bericht, wenn die gleiche Überschrift gefunden wird.

Dieses Bild kann helfen, zu verstehen. Erklärung

Mein erster Versuch:

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 

Ich erhalte einen Fehler von Anwendungs ​​definiert oder Objekt definierte Fehler Laufzeit 1004. Gibt es etwas falsch mit meiner Logik/Syntax ..?

Bitte helfen, ich bin so schlecht in VBA.

Vielen Dank im Voraus!

Answer 1

Ihr zuletzt bearbeiten Code funktioniert

aber Sie unnötige Kontrollen machen und ich werde Sie eine Schleife durch jedes Blatt Kopf vorschlagen und prüfen, ob es in TargetHeader Bereich existiert möglicherweise anschließend kopiert seine Spalte SourceWB

außerdem können Sie Ihren Code robuster haben, und überprüfen Sie die tatsächlichen Arbeitsmappen/Arbeitsblätter Existenz, bevor Sie wollte, dass sie setzen Variablen

wie folgt:

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