Spalten aus mehreren Dateien in eine neue Arbeitsmappe kopieren

[Blanky]

Hallo zusammen,
ich sitze seit mehreren Tagen an folgendem Problem  

Ich habe 4 Dateien, nennen wir sie mal Frühling.xlsx, Sommer.xlsx, Herbest.xlsx und Winter.xlsx
Ich möchte nun aus diesen 4 Dateien einzelne Spalten herauskopieren und in eine neue Arbeitsmappe "Jahreszeiten" einfügen. Spalte A ist in allen 4 Tabellen identisch.

Aus der Tabelle Frühling sind es die Spalten "Tulpe", "Flieder" und "Grün"
Aus der Tabelle Sommer sind es die Spalten "Sonne", "Badesee", "Strandkorb" und "Biergarten"
Aus der Tabelle Herbst sind es die Spalten "Laub", "Ernte" und "Nebel"
Aus der Tabelle Winter sind es die Spalten "Schnee", "Advent" und "Weihnachten"

Die neue Arbeitsmappe soll dann die Spalten Spalte A - Tulpe - Flieder - Grün - Sonne - Badesee - Standkorb - Biergarten - Laub - Ernte - Nebel - Schnee - Advent - Weihnachten enthalten

Alle 4 Dateien stehen in demselben Verzeichnis. D:\Excel\Daten

Ich habe es mit einem Makro probiert allerdings ohne Erfolg. Ich denke, dass das nur mit VBA geht. Aber genau das kann ich nicht.

Ich hoffe, der ein oder andere von Euch EXCEL-Götter kann mir da weiterhelfen, damit ich das Problem lösen kann.

Vieln Dank im Voraus

Blanky

[Ralf A]

Hi Blanky,

Ich habe es mit einem Makro probiert allerdings ohne Erfolg. Ich denke, dass das nur mit VBA geht. Aber genau das kann ich nicht.

Nun, ein Makro, das ist VBA. :) Brauchst Du aber auch nicht. Schau Dir mal dieses Tutorial an.

[UweD]

Hallo

Ich gehe davon aus, das die Quellspalten immer im ersten Blatt der Dateien sind

- Dieses Makro in eine Modul in der Datei "Jahreszeiten"
- Achte bei ArrTB genau auf die gesetzten " 

Code:

Sub DasJahr()
    Dim Pfad As String, ArrWB, TB5 As Worksheet, ArrTB, Datei As String
    Dim WBx As Workbook, Spalte, ZSp As Integer, i As Integer
    Dim WF
   
    Pfad = "E:\Excel\Temp\" 'mit \ am Ende
    Set TB5 = ThisWorkbook.Sheets(1)
   
    ArrWB = Array("Frühling.xlsx", "Sommer.xlsx", "Herbest.xlsx", "Winter.xlsx")
   
    ArrTB = Array("Tulpe, Flieder, Grün", _
                  "Sonne, Badesee, Strandkorb, Biergarten", _
                  "Laub, Ernte, Nebel", _
                  "Schnee, Advent, Weihnachten")
   
   
    Set WF = WorksheetFunction
   
    'Reset
    TB5.UsedRange.ClearContents
   
    For i = LBound(ArrWB) To UBound(ArrWB)
        Datei = Pfad & ArrWB(i)
        If Dir(Datei) = "" Then
            MsgBox Datei & " nicht gefunden"
        Else
            Set WBx = Workbooks.Open(Datei)
            With WBx.Sheets(1)
                If ZSp = 0 Then ' Spalte A nur 1x
                    .Columns(1).Copy TB5.Columns(ZSp + 1)
                    ZSp = ZSp + 1
                End If
               
                For Each Spalte In Split(ArrTB(i), ", ")
                    If WF.CountIf(.Rows(1), Trim(Spalte)) > 0 Then 'Ist Spalte vorhanden?
                        .Columns(WF.Match(Trim(Spalte), .Rows(1), 0)).Copy TB5.Columns(ZSp + 1)
                        ZSp = ZSp + 1
                    Else
                        MsgBox "'" & Trim(Spalte) & "' in '" & ArrWB(i) & "' nicht gefunden"
                    End If
                Next
               
            End With
            WBx.Close False
        End If
    Next
   
End Sub

LG UweD