Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1376to1380
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zusammenführung von Dateien

Zusammenführung von Dateien
14.08.2014 16:19:38
Dateien
Hallo Zusammen,
ich hab jetzt schon stunden bei Google nach einer lösung für mein Problem gesucht jedoch nicht das richtige gefunden :-(.
Ich habe mehrere Excel Dateien mit jeweils einer Tabelle in einem Ordner. Ich bräuchte nun ein Makro, welches diese Excel Dateien zu einer macht. Sprich ich habe eine Datei A mit Tabelle A welche in eine neue Datei in Tabelle 1 eingefügt werden soll, Datei B mit Tabelle B soll in die neue Datei in Tabelle 2 eingefügt werden, Datei C mit Tabelle C soll in die neue Datei in Tabelle 3 eingefügt werden und so weiter. Die Tabellen in den einzelnen Excel Dateien sind immer unterschiedlich lang und es sind auch immer unterschiedlich viele Excel Dateien.
Es sollten alle Exceldateien aus dem Order in die neue Datei eingefügt werden, wobei der Name der Tabellen/Mappen in der neuen Datei den Namen der Exceldateien entspricht. Den Pfad bzw. die Dateien, welche in die neue Datei eingefügt werden sollen, soll Excel bei Start des Makros abfragen.
Ich hab selber schon ein wenig rumprobiert, komme da aber zu keiner passenden Lösung, hoffe Ihr könnt mir helfen, ein Meeeeeeeeeeeggggggggga Dankeschön schonmal vorab. :-)
LG Steffen

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zusammenführung von Dateien
14.08.2014 17:44:23
Dateien
Hallo Steffen,
schreibe die Pfade , die Arbeitsmappen(Namen) und die zu kopierenden Tabellenblattnamen in die Spalten A, B und C untereinander. Für das Beispielmakro beginnst Du damit in Zeile 2. Die Pfadnamen im Makro musst Du noch anpassen:
Sub daten_aus_wbs()
Dim myWb As Workbook
Dim mySh As Worksheet
Dim myPath As String
Dim myFile As String
Dim myTab As String
Dim zeile As Long
Set myWb = ThisWorkbook
Set mySh = myWb.Sheets("Dateien")
myPath = mySh.Range("A2").Value
myFile = mySh.Range("B2").Value
myTab = mySh.Range("C2").Value
With mySh
For zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Workbooks.Open fileName:=myPath & "/" & myFile
Sheets(myTab).Copy after:=Workbooks(myWb.Name).Sheets(mySh.Name)
Windows(myFile).Close savechanges:=False
ActiveSheet.Name = myTab
Next
End With
End Sub
Gruß
Jochen

Anzeige
AW: Zusammenführung von Dateien
15.08.2014 10:10:58
Dateien
Guten Morgen Jochen,
vielen Dank schonmal für deine Mühe, jedoch ist es nicht ganz was ich suche :-(
Ich versuche es nochmal genauer zu schildern:
Als Beispiel:
Ich habe einen Ordner mit 3 Exceldateien/Workbooks, (DateiA, DateiB,DateiC in denen jeweils in Sheet1 Daten enthalten sind. Nun soll aus diesen 3 Exceldateien/Workbooks jeweils das Sheet1 Kopiert und in eine neue Exceldatei/Workbook eingefügt werden, jedoch nicht alle Daten aus den 3 Exceldateien/Workbooks in Sheet1 sondern für jede der 3 Dateien/Workbooks soll ein eigenenes Sheet in der neuen Datei/Workbook angelegt werden, sodass ich am Ende eine Exceldatei mit 3 Sheets habe in denen die Daten enthalten sind.
Also:
1. Excel soll nach dem Pfad Fragen, wo die Exceldateien/Workbooks liegen, dass hab ich schon mit
Application.GetOpenFilename("Excel Files(*.xlsx),*.xlsm", hinbekommen.
2. Jeweils das erste Sheet aus den ausgewählten Dateien/Workbooks soll kopiert werden (Das erste Sheet aller ausgewählert Workbooks)
3. Jetzt soll eine neue Datei/Workbook geöffnet werden. Für jede ausgewählte Datei/Workbook soll nun ein eigendes Sheet in der neuen Datei/Workbook erstellt werden. wo die Daten eingefügt werden.
Das Problem ist, dass ich immer unterschiedlich viele ExcelDateien/Workbooks auswählen muss und die Tabellen/Daten in den Sheets sind immer unterschiedlich lang, jedoch immer gleich breit.
Danke,Danke,Danke
Steffen ;-)

Anzeige
AW: Zusammenführung von Dateien
17.08.2014 22:31:38
Dateien
Keiner eine Idee wie das funktionieren könnte? :-(

AW: Zusammenführung von Dateien
18.08.2014 10:05:03
Dateien
Hallo Steffen,
eine intensive Suche in der RECHERCHE hätte sicher was brauchbares zu Tage gefördert.
Gruß
Franz
Sub Tabelle1_Holen_aus_Dateien()
'1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe zusammenkopieren
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim varVerzeichnis As Variant
Dim wkbQuelle As Workbook, wksQuelle As Worksheet
Dim strDatei As String, intK As Integer
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die zusammengefasst werden  _
sollen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
strDatei = Dir(varVerzeichnis & "\*.xls*")
If strDatei = "" Then
MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
Exit Sub
End If
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
If LCase(strDatei)  LCase(ThisWorkbook.Name) Then
intK = intK + 1
Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
Set wkbQuelle = Application.Workbooks.Open(Filename:=varVerzeichnis & "\" & strDatei, _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wkbQuelle.Worksheets(1)
wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn Formeln vorhanden sind
'wenn keine Formeln kopiert werden sollen
With wksQuelle.UsedRange
.Value = .Value
End With
'Blatt in neue Mappe kopieren
If wkbZiel Is Nothing Then
wksQuelle.Copy
Set wkbZiel = ActiveWorkbook
Else
wksQuelle.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
End If
'kopiertes Blatt umbenennen
Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
wksZiel.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
'Quelldatei ohne speichern wieder schließen
wkbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End If
strDatei = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Select
End With
Beenden:
End Sub

Anzeige
AW: Zusammenführung von Dateien
18.08.2014 14:34:13
Dateien
Hallo Franz,
wie gesagt meine VBA Kentnisse sind "bescheiden" ich verstehe leider erst einen kleinen Teil dessen, was die einzelnen Commends wirklich ausführen und wie das ganze dann im Zusammenspiel funktioniert. Wenn ich das alles wüsste, hätte ich mit sicherheit was gefunden.
Riesen Dankeschön schonmal für deinen Code :-)
Ich hoffe du hilfst mir nochmal, wie müsste man den Code verändern, damit aus der zu Kopierenden Tabelle1 immer nur ein bestimmter Bereich sagen wir als Beispiel mal A18:B118 Kopiert wird.
Ich habe jetzt schon ein wenig rum probiert, hoffe das ich an der richtigen stelle Probiert habe.
Set wksQuelle = wkbQuelle.Worksheets(1).Range("A18:B116").Selection
oder
Set wksQuelle = wkbQuelle.Worksheets(1).Sheet.Range"A18:B116")
klappt leider nicht :(

Anzeige
AW: Zusammenführung von Dateien
19.08.2014 09:15:01
Dateien
Guten Morgen,
habe nun Gestern noch probiert und gegoogelt und herausgefunden, dass mit
With wksQuelle.UsedRange
.Value = .Value
End With
der gesamte Bereich angesprochen wird, welcher genutzt wird.
Wenn ich es jetzt auf:
With wksQuelle.Range("A23:Z120")
.Value = .Value
End With
ändere, läuft es allerdings auf einen Fehler :-/ Ich hab dann noch weiter rumprobiert aber egal wie ich es drehe und wende komme ich immer wieder auf einen Fehler...

AW: Zusammenführung von Dateien
19.08.2014 10:48:02
Dateien
Hallo Steffen,
im Moment wird ja immer das komplette Tabellenblatt nach der Umwandlung von Formeln in Werte von der Quelldatei in die Zieldatei kopiert. Das hat den Vorteil, dass man sich nicht um Formatierungen und Seitenlayout des Tabellenblatts kümmern. Probleme gibt es "nur", wenn die Quelldateien alte (2003 und älter) und neue (2007 und jünger) Dateiformate beinhalten.
Grundsätzlich gäbe es jetzt 2 Varianten:
A) Nach dem Kopieren des Blattes in die Zieldatei werden die nicht benötigten Spalten und Zeilen gelöscht.
B) Aus der Tabelle der 1. Quelldatei wird eine Mustertabelle generiert.
Bei den weiteren Quelldateien wird dann jeweils die Mustertabelle kopiert und der gewünschte Quelldatenbereich hineinkopiert.
Nachfolgended findest du das ursprüngliche Makro angepasst für beide Varianten.
Hier musst du die Zeilen-/Spaltenbereiche und den zu kopierenden Bereich anpassen.
Gruß
Franz
'Variante A
Sub Tabelle1_Holen_aus_Dateien_A()
'1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe zusammenkopieren
'und nicht gewünschte Daten löschen
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim varVerzeichnis As Variant
Dim wkbQuelle As Workbook, wksQuelle As Worksheet
Dim strDatei As String, intK As Integer
Dim Zeile_L As Long, Spalte_L As Long
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
& "zusammengefasst werden sollen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
strDatei = Dir(varVerzeichnis & "\*.xls*")
If strDatei = "" Then
MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
Exit Sub
End If
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
If LCase(strDatei)  LCase(ThisWorkbook.Name) Then
intK = intK + 1
Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
Set wkbQuelle = Application.Workbooks.Open( _
Filename:=varVerzeichnis & "\" & strDatei, _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wkbQuelle.Worksheets(1)
wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
'wenn keine Formeln kopiert werden sollen
With wksQuelle.UsedRange
.Value = .Value
End With
'Blatt in neue Mappe kopieren
If wkbZiel Is Nothing Then
wksQuelle.Copy
Set wkbZiel = ActiveWorkbook
Else
wksQuelle.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
End If
'kopiertes Blatt umbenennen
Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
With wksZiel
.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
'Überzälige Zeilen löschen - von unten her
'- Zeilen am Ende der Liste
If Zeile_L > 120 Then
.Range(.Rows(121), .Rows(Zeile_L)).Delete
End If
'- Zeilen am Anfang der Liste
.Range(.Rows(1), .Rows(22)).Delete
'Überzälige Spalten löschen - rechts kommend
'- Spalten rechts in Liste
If Spalte_L > 26 Then
.Range(.Columns(27), .Columns(Spalte_L)).Delete
End If
'- Spalten links in Liste
'nicht zutreffend
End With
'Quelldatei ohne speichern wieder schließen
wkbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End If
'nächste Datei suchen
strDatei = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Select
End With
Beenden:
End Sub
'Variante B
Sub Tabelle1_Holen_aus_Dateien_B()
'Daten aus 1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe  _
zusammenkopieren
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim varVerzeichnis As Variant
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, wksMuster As Worksheet
Dim strDatei As String, intK As Integer
Dim Zeile_L As Long, Spalte_L As Long
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
& "zusammengefasst werden sollen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
strDatei = Dir(varVerzeichnis & "\*.xls*")
If strDatei = "" Then
MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
Exit Sub
End If
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
If LCase(strDatei)  LCase(ThisWorkbook.Name) Then
intK = intK + 1
Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
Set wkbQuelle = Application.Workbooks.Open( _
Filename:=varVerzeichnis & "\" & strDatei, _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wkbQuelle.Worksheets(1)
wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
'wenn keine Formeln kopiert werden sollen
With wksQuelle.UsedRange
.Value = .Value
End With
'Blatt in neue Mappe kopieren
If wkbZiel Is Nothing Then
wksQuelle.Copy
Set wkbZiel = ActiveWorkbook
Set wksMuster = wkbZiel.Worksheets(1)
With wksMuster
.Name = "Musterblatt"
'Musterblatt aufbereiten
'Inhalte im Zieldatenbereich löschen
.Range("A23:Z120").ClearContents
'letzte Zeile und Spalte ermitteln
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
'Überzälige Zeilen löschen - von unten her
'- Zeilen am Ende der Liste
If Zeile_L > 120 Then
.Range(.Rows(121), .Rows(Zeile_L)).Delete
End If
'- Zeilen am Anfang der Liste
.Range(.Rows(1), .Rows(22)).Delete
'Überzälige Spalten löschen - rechts kommend
'- Spalten rechts in Liste
If Spalte_L > 26 Then
.Range(.Columns(27), .Columns(Spalte_L)).Delete
End If
'- Spalten links in Liste
'nicht zutreffend
Application.ScreenUpdating = True
.Range("A1").Select
Application.ScreenUpdating = False
End With
End If
'Musterblatt kopieren
wksMuster.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
'kopiertes Blatt umbenennen
Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
With wksZiel
.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
wksQuelle.Range("A23:Z120").Copy Destination:=.Cells(1, 1)
End With
'Quelldatei ohne speichern wieder schließen
wkbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End If
'nächste Datei suchen
strDatei = Dir
Loop
'Musterblatt wieder löschen
Application.DisplayAlerts = False
wksMuster.Delete
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Select
End With
Beenden:
End Sub

Anzeige
AW: Zusammenführung von Dateien
19.08.2014 14:01:50
Dateien
Hallo Frank,
vielen Dank nochmal für deine Bemühungen, es funktioniert fast genauso wie es sein sollte es sind nurnoch 2 kleinigkeiten die ich leider auch durch meine Kenntnisse nicht fixen kann.
Ich hab mich für die Variante A entschieden und nur die oberen 22 Zeilen gelöscht.
1. Nun meckert das Makro jedoch rum, da in den zu kopierenden Tabellenblättern ein paar Zellen gesperrt sind, damit man nicht ausversehen die darunterliegenden Formeln verändert. Ich bräcuhte also eine Lösung, in der vor dem kopieren der Blattschutz für das Worksheet aufgehoben wird. ( Es sollen jedoch wie es in dem Makro funktioniert nur die Werte und das Format kopiert werden.)
mit ReadOnly:=False klappt es leider nicht und auch nicht wenn ich noch IgnoreReadOnlyRecommended=:True eintage.
2. in Zelle A23 der zu kopierenden Tabellenblätter steht immer eine Überschrift die 2 Farbig ist. Die ersten 5 Buchstaben sind dabei Blau die folgenden 4-12 Buchstaben sind Schwarz. Das Makro kopiert die Überschrift komplett in Blau in die neue Datei. Ist das überhaupt möglich soetwas durch ein Makro zu formatieren?
Beste Grüße
Steffen

Anzeige
AW: Zusammenführung von Dateien
19.08.2014 15:52:56
Dateien
Hallo Steffen,
passen den folgenden Abschnitt des Makros an.
Der Blattschutz wird jetzt aufgehoben und in Zelle A23 wird die Zeichenformatierung wieder hergestellt. Dabei werden die Zeichen ab dem 6. Zeichen schwarz formatiert, da die Basisfarbe der Schrift korrekt mit blau ist.
Gruß
Franz
      'wenn keine Formeln kopiert werden sollen
wksQuelle.Unprotect Password:=""
With wksQuelle.UsedRange
.Value = .Value
End With
With wksQuelle.Range("A23")
If Len(.Text) > 5 Then
With .Characters(6, Len(.Text) - 5).Font
.Color = RGB(Red:=0, Green:=0, Blue:=0)
End With
End If
End With
'Blatt in neue Mappe kopieren

Anzeige
AW: Zusammenführung von Dateien
19.08.2014 16:24:42
Dateien
Woaaaa genial Franz :-)
was man mit Excel nicht alles machen kann :-O
Klappt das auch das Excel Wörter erkennen kann? Sprich ich habe in Zelle A23 eine Überschrift diese hat immer folgendes Muster: "Wort - Wort".
nun soll das
1. Wort blau,
der "-" blau und das
2. Wort die ersten 5 Buchstaben blau alle weiteren Buchstaben Schwarz?

AW: Zusammenführung von Dateien
19.08.2014 17:58:22
Dateien
Hallo Steffen,
mit variabler Färbung der Zeichen sieht es so aus:
      'wenn keine Formeln kopiert werden sollen
wksQuelle.Unprotect Password:=""
With wksQuelle.UsedRange
.Value = .Value
End With
With wksQuelle.Range("A23")
If InStr(1, .Text, "-") > 0 Then
'Bindestrich im Text vorhanden - ab 6. Zeichen nach dem Bindestrich schwarz
Spalte_L = InStr(1, .Text, "-") + 7
Else
'kein Bindestrich im Text - ab 6. Zeichen schwarz
Spalte_L = 6
End If
If Len(.Text) >= Spalte_L Then
With .Characters(Spalte_L, Len(.Text) - (Spalte_L - 1)).Font
.Color = RGB(Red:=0, Green:=0, Blue:=0)
End With
End If
End With
'Blatt in neue Mappe kopieren

Gruß
Franz
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige