Wie kann ich Bestimmte Zellen aus mehreren Dateien kopieren? - VBA Makro

Question

Ich habe auch schon einen Code der an sich gut funktioniert nur leider nicht die Mehrfachauswahl.

Sub Übertragen()
 Dim Datei As Variant
 Dim Quelle, Ziel As String
 Dim bExists, MappeOffen As Boolean
 Dim i As Integer
 Dim lZeile As Long
 Dim Rückgabe

 'Datei-Öffnen Dialog aufrufen
 Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="Datei(en) auswählen", MultiSelect:=True)
 If Datei = False Then
 Exit Sub
 End If

 'Prüfen, ob Datei schon offen ist
 For i = 1 To Workbooks.Count
 If Workbooks(i).FullName = Datei Then
 'ausgewählte Mappe ist bereits offen
 MappeOffen = True
 'Frage, ob Daten kopiert werden sollen
 Rueckgabe = MsgBox("Die Arbeitsmappe " & Quelle & " ist bereits offen! Sollen die Daten kopiert werden?", vbYesNo + vbQuestion, "Mappe bereits offen")
 'Abbruch des Makros
 If Rueckgabe = vbNo Then Exit Sub
 'Name der Quelldatei in Variable schreiben
 Quelle = Workbooks(i).Name
 End If
 Next i

 'Bildschirmaktualisierung ausschalten:
 Application.ScreenUpdating = False

 'ausgewählte Datei öffnen, falls diese noch nicht offen ist
 If MappeOffen = False Then
 Workbooks.Open (Datei)
 'Name der Quelldatei in Variable schreiben
 Quelle = ActiveWorkbook.Name
 End If

 'Name der Zielarbeitsmappe wird in Datei geschrieben
 Ziel = ThisWorkbook.Name

 'Prüfen, ob Tabellenblatt mit Namen Sheet1 in Quelldatei existiert
 For i = 1 To Workbooks(Quelle).Sheets.Count
 If Workbooks(Quelle).Sheets(i).Name = "Sheet1" Then
 bExists = True: Exit For
 End If
 Next i

 'Abbruch des Makros falls kein Arbeitsblatt mit dem Namen Sheet1 existiert
 If bExists = False Then
 MsgBox "In der Arbeitsmappe " & Quelle & " existiert kein Arbeitsblatt mit dem Namen Sheet1! Abbruch!", 16, "Fehlermeldung"
 Exit Sub
 End If

 'Festlegen der Zeile zum Einfügen der Daten in Tabelle1
 lZeile = Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

 'Prüfen, ob erste Zeile leer ist, falls ja, Zeilenzähler auf 1 setzen
 If Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
 If IsEmpty(Workbooks(Ziel).Sheets("Tabelle1").UsedRange) Then lZeile = 1
 End If

 'Kopieren der Daten - E3 wird nach Spalte A kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("b2").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 1).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
 'Kopieren der Daten - E3 wird nach Spalte A kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("c2").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 2).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
 'Kopieren der Daten - E3 wird nach Spalte A kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("f2").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 3).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
 'P3 wird nach Spalte B kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("b7").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 11).PasteSpecial Paste:=xlPasteValues
 'P4 wird nach Spalte C kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("b10").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 12).PasteSpecial Paste:=xlPasteValues

 'K52 wird nach Spalte D kopiert
 Workbooks(Quelle).Sheets("Sheet1").Range("f25").Copy
 Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 13).PasteSpecial Paste:=xlPasteValues

 'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
 If MappeOffen = False Then Workbooks(Quelle).Close SaveChanges:=False

 'Bildschirmaktualisierung einschalten:
 Application.ScreenUpdating = True

End Sub

Answer 1

Hallo Smiddie,

wenn du eine Mehrfachauswahl nutzt, musst du per Schleife die einzelnen Dateien öffnen. Versuche mal den folgenden Code:

Sub Übertragen()
Dim Quelle As String
Dim Ziel As String
Dim bExists As Boolean
Dim MappeOffen As Boolean
Dim i As Integer
Dim lZeile As Long
Dim Rückgabe
Dim varDateien As Variant
Dim n As Integer

 'Datei-Öffnen Dialog aufrufen
 varDateien = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="Datei(en) auswählen", MultiSelect:=True)
 If IsArray(varDateien) = False Then Exit Sub
 
 'ausgewählte Dateien öffnenen
 For n = LBound(varDateien) To UBound(varDateien)
   'Prüfen, ob Datei schon offen ist
    For i = 1 To Workbooks.Count
       If Workbooks(i).FullName = varDateien(n) Then
          'ausgewählte Mappe ist bereits offen
           MappeOffen = True
           'Frage, ob Daten kopiert werden sollen
            Rueckgabe = MsgBox("Die Arbeitsmappe " & Quelle & " ist bereits offen! Sollen die Daten kopiert werden?", vbYesNo + vbQuestion, "Mappe bereits offen")
           'Abbruch des Makros
           If Rueckgabe = vbNo Then Exit Sub
           'Name der Quelldatei in Variable schreiben
           Quelle = Workbooks(i).Name
       End If
    Next i

   'Bildschirmaktualisierung ausschalten:
   Application.ScreenUpdating = False

   'ausgewählte Datei öffnen, falls diese noch nicht offen ist
   If MappeOffen = False Then
     Workbooks.Open (varDateien(n))
     'Name der Quelldatei in Variable schreiben
     Quelle = ActiveWorkbook.Name
   End If

   'Name der Zielarbeitsmappe wird in Datei geschrieben
   Ziel = ThisWorkbook.Name

   'Prüfen, ob Tabellenblatt mit Namen Sheet1 in Quelldatei existiert
    For i = 1 To Workbooks(Quelle).Sheets.Count
      If Workbooks(Quelle).Sheets(i).Name = "Sheet1" Then
        bExists = True
        Exit For
      End If
    Next i

    'Abbruch des Makros falls kein Arbeitsblatt mit dem Namen Sheet1 existiert
     If bExists = False Then
        MsgBox "In der Arbeitsmappe " & Quelle & " existiert kein Arbeitsblatt mit dem Namen Sheet1! Abbruch!", 16, "Fehlermeldung"
        Exit Sub
     End If

   'Festlegen der Zeile zum Einfügen der Daten in Tabelle1
    lZeile = Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

    'Prüfen, ob erste Zeile leer ist, falls ja, Zeilenzähler auf 1 setzen
    If Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
      If IsEmpty(Workbooks(Ziel).Sheets("Tabelle1").UsedRange) Then lZeile = 1
    End If

    'Kopieren der Daten - B2 wird nach Spalte A kopiert
    Workbooks(Quelle).Sheets("Sheet1").Range("B2").Copy
    Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 1).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
    'Kopieren der Daten - C2 wird nach Spalte B kopiert
    Workbooks(Quelle).Sheets("Sheet1").Range("C2").Copy
    Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 2).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
   'Kopieren der Daten - F2 wird nach Spalte C kopiert
    Workbooks(Quelle).Sheets("Sheet1").Range("F2").Copy
    Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 3).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
 
    'B7 wird nach Spalte K kopiert
    Workbooks(Quelle).Sheets("Sheet1").Range("B7").Copy
    Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 11).PasteSpecial Paste:=xlPasteValues
   'B10 wird nach Spalte L kopiert
    Workbooks(Quelle).Sheets("Sheet1").Range("B10").Copy
    Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 12).PasteSpecial Paste:=xlPasteValues

   'F25 wird nach Spalte M kopiert
   Workbooks(Quelle).Sheets("Sheet1").Range("F25").Copy
   Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 13).PasteSpecial Paste:=xlPasteValues

   'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
   If MappeOffen = False Then Workbooks(Quelle).Close SaveChanges:=False

Next n

 'Bildschirmaktualisierung einschalten:
 Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 2

Hi,

man könnte das noch etwas vereinfachen:

Sub Übertragen()
    Dim strQuelle As String
    Dim strZiel As String
    Dim bExists As Boolean
    Dim i As Integer
    Dim lZeile As Long
    Dim Rückgabe
    Dim varDateien As Variant
    Dim arrOffen()
    Dim wkbMappe As Workbook
    Dim varOffen As Variant
    Dim lngZaehler As Long
    Dim blnOffen As Boolean
    'Name der Zielarbeitsmappe wird in Variable geschrieben
    strZiel = ThisWorkbook.Name
    'alle offenen Arbeitsmappen ins Array schreiben
    For Each wkbMappe In Workbooks
        ReDim Preserve arrOffen(0 To lngZaehler)
        arrOffen(lngZaehler) = wkbMappe.Name
        lngZaehler = lngZaehler + 1
    Next wkbMappe
    'Datei-Öffnen Dialog aufrufen
    varDateien = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="Datei(en) auswählen", MultiSelect:=True)
    If IsArray(varDateien) = False Then Exit Sub
    'Bildschirmaktualisierung ausschalten:
    Application.ScreenUpdating = False
    'Schleife über alle ausgewählten Arbeitsmappen
    For lngZaehler = LBound(varDateien) To UBound(varDateien)
        ' Prüfung ob im Array der offenen Mappe enthalten
        varOffen = Application.Match(Mid(varDateien(lngZaehler), InStrRev(varDateien(lngZaehler), "\") + 1), arrOffen(), 0)
        If IsNumeric(varOffen) Then
            strQuelle = arrOffen(varOffen - 1)
            blnOffen = True
        Else
            Workbooks.Open varDateien(lngZaehler)
            strQuelle = Mid(varDateien(lngZaehler), InStrRev(varDateien(lngZaehler), "\") + 1)
        End If
        'Prüfen, ob Tabellenblatt mit Namen Sheet1 in Quelldatei existiert
        For i = 1 To Workbooks(strQuelle).Sheets.Count
            If Workbooks(strQuelle).Sheets(i).Name = "Sheet1" Then
                bExists = True
                Exit For
            End If
        Next i
        If bExists = False Then
            MsgBox "In der Arbeitsmappe " & strQuelle & " existiert kein Arbeitsblatt mit dem Namen Sheet1! Mappe wird übersprungen"
            If blnOffen = False Then Workbooks(strQuelle).Close SaveChanges:=False
        Else
            'Festlegen der Zeile zum Einfügen der Daten in Tabelle1
            If Application.CountA(Workbooks(strZiel).Worksheets("Tabelle1").Cells) = 0 Then
                lZeile = 1
            Else
                lZeile = Workbooks(strZiel).Worksheets("Tabelle1").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            'Daten kopieren
            With Workbooks(strQuelle).Sheets("Sheet1")
                Union(.Range("B2"), .Range("C2"), .Range("F2")).Copy
                Workbooks(strZiel).Sheets("Tabelle1").Cells(lZeile, 1).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
                Union(.Range("B7"), .Range("B10")).Copy
                Workbooks(strZiel).Sheets("Tabelle1").Cells(lZeile, 11).PasteSpecial Paste:=xlPasteValues
                .Range("F25").Copy
                Workbooks(strZiel).Sheets("Tabelle1").Cells(lZeile, 13).PasteSpecial Paste:=xlPasteValues
            End With
            'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
            If blnOffen = False Then Workbooks(strQuelle).Close SaveChanges:=False
       End If
       blnOffen = False
       bExists = False
    Next lngZaehler
    'Bildschirmaktualisierung einschalten:
    Application.ScreenUpdating = True
End Sub

Bis später, Karin