Bestimmte Zellen aus mehreren Tabellen in eine Zusammenfassungstabelle kopieren mit Makro

Question

Guten Morgen,
ich habe die Aufgabe bekommen ein Makro zu erstellen, welches aus mehreren Excel Dateien, die in einem Ordner gespeichert sind, immer die gleichen Zellen (Tabelle 4, AE 19, AF19, AE31, AF31, AE35, AF35) kopiert und diese in einer neuen Datei (Zusammenfassung) speichert.
Die Zellen sollen jeweils folgendermassen gespeichert werden.
AE 19 --> B3
AF19 --> C3
AE31 --> B4
AF31 --> C4
AE35 --> B5
AF35 --> C5

Der Ordner in welchem alle Dateien gespeichert sind ist nicht immer am selben platz gespeichert, aus diesem Grund sollte am Anfang ein Fenster erscheinen in welchem man den quellenort aussuchen kann ( dieses Auswahlfenster habe ich schon hin bekommen)

Meine Kenntnisse in der Programmierung von Makros sind eher gering, desswegen bin ich fuer jede Hilfe dankbar.

Answer 1

Hallo,

kopiere das folgende Makro in ein Modul deiner Arbeitsmappe "Zusammenfassung".
Den Namen der Zieltabelle musst du ggf. noch anpassen:

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

'Name des Arbeitsblatts, in den die Daten hereinkopiert werden, wird hier festgelest - ggf. anpassen!!
WSZiel = "Tabelle1"

'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="EINE Datei zum Öffnen auswählen")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
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 Tabelle4 in Quelldatei existiert
For i = 1 To Workbooks(Quelle).Sheets.Count
If Workbooks(Quelle).Sheets(i).Name = "Tabelle4" Then
bExists = True: Exit For
End If
Next i

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

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

'Prüfen, ob erste Zeile die Nummer 3 hat, falls kleiner erhöhen
If lZeile < 3 Then lZeile = 3

'Kopieren der Daten
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 2) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE19").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 3) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF19").Value
'Zeilenzähler erhöhen
lZeile = lZeile + 1
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 2) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE31").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 3) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF31").Value
lZeile = lZeile + 1
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 2) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE35").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 3) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF35").Value


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

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Meldung, dass Daten kopiert wurden
MsgBox "Die Daten aus der Datei " & Quelle & " wurden kopiert!", 64, "Information"


End Sub

Gruß

M.O.

Answer 2

Vielen Dank M.O.

das Makro funktioniert bei mir optimal.

Ich noch eine Anmerkung welche ich bei der Fragestellung falsch formuliert habe. Un zwar sollen diese zellen aus mehreren Tabellen kopiert werden. Ich habe also mehr Quelltabellen. Diese sollen in die Spalten hinter den kopierten Zellen aus der ersten Quelldatei eingefuegt werden.

Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="EINE Datei zum Öffnen auswählen")

muss desshalb an dieser codestelle etwas veraendert werden?

Gruss

mo.choice ;-)

Answer 3

Hallo mo.choice,

nein, da muss nichts geändert werden. Diese Zeile dient nur zum Öffnen der Datei.
Ich hatte den Code so geschrieben, dass die Werte aus weiteren Dateien unter die ersten Werte geschrieben werden.

Hier der angepasste Code:

Sub Oeffnen_und_kopieren2()
Dim Datei As Variant
Dim Quelle, Ziel, WSZiel As String
Dim bExists, MappeOffen As Boolean
Dim i As Integer
Dim lSpalte As Long
Dim Rückgabe

'Name des Arbeitsblatts, in den die Daten hereinkopiert werden, wird hier festgelest - ggf. anpassen!!
WSZiel = "Tabelle1"

'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="EINE Datei zum Öffnen auswählen")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
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 Tabelle4 in Quelldatei existiert
For i = 1 To Workbooks(Quelle).Sheets.Count
If Workbooks(Quelle).Sheets(i).Name = "Tabelle4" Then
bExists = True: Exit For
End If
Next i

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

'Festlegen der Spalte zum Einfügen der Daten in Zielarbeitsblatt
lSpalte = Workbooks(Ziel).Sheets(WSZiel).UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1

'Prüfen, ob erste Spalte die Nummer 2 (=B) hat, falls kleiner erhöhen
If lSpalte < 2 Then lSpalte = 2

'Kopieren der Daten
Workbooks(Ziel).Sheets(WSZiel).Cells(3, lSpalte) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE19").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(3, lSpalte + 1) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF19").Value
'Zeilenzähler erhöhen
lZeile = lZeile + 1
Workbooks(Ziel).Sheets(WSZiel).Cells(4, lSpalte) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE31").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(4, lSpalte + 1) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF31").Value
lZeile = lZeile + 1
Workbooks(Ziel).Sheets(WSZiel).Cells(5, lSpalte) = Workbooks(Quelle).Sheets("Tabelle4").Range("AE35").Value
Workbooks(Ziel).Sheets(WSZiel).Cells(5, lSpalte + 1) = Workbooks(Quelle).Sheets("Tabelle4").Range("AF35").Value


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

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Meldung, dass Daten kopiert wurden
MsgBox "Die Daten aus der Datei " & Quelle & " wurden kopiert!", 64, "Information"


End Sub

Gruß

M.O. ;-)