Supportnet / Forum / Tabellenkalkulation
Inhalte von 500 Dateien in Eine als Liste per Makro kopieren
Frage
Hallo liebe Leute,
ich habe trotz intensiver Suche keine Lösung zu folgendem Problem gefunden - ich wäre sehr dankbar, wenn mir jemand helfen könnte:
Es geht um eine Auswertung/Zusammenfassung einer Umfrage...
ich habe 540 excel-Dateien/Arbeitsmappen unterschiedlichen Namens, jedoch gleicher Inhaltsstruktur, mit jeweils nur einem Blattregister.
In Spalte A sind Fragen, in Spalte B sind Antworten.
Diese 540 Arbeitsmappen möchte ich in einer neuen Arbeitsmappe zusammenfassen bzw. eine Liste erstellen, in der alle Fragen und Antworten der 540 Dateien untereinander stehen.
Mit Pivot-Tabellen kann ich die entstandene Liste dann bequem zusammenfassen/auswerten.
ABER: - Wie kann ich die 540 Dateien per Makro in eine Arbeitsmappe als Liste bringen, ohne, daß ich 540 mal alle Dateien öffnen und schließen muß?
Ich habs schon mal mit dem Makrorekorder probiert, aber es hat nicht funktioniert (es wird immer wieder an die gleiche Stelle kopiert, statt untereinander...)
Wer hat Ahnung? Für wen ist das kein Problem?
-> der schreibe mir schnell....
Ich danke schon mal im Voraus!
cu
mckott
Antwort 1 von ComputerFee
Hallo mckott,
da die Dateien alle die gleiche Struktur ( gleiche Anzahl an Zeilen ) aufweisen, würde ich folgendermaßen vorgehen:
Du erzeugst einen DateiZaehler, den Du zu Beginn auf 0 initialisierst.
Beim Öffnen einer Datei, erhöhst Du den Zaehler um 1.
Um die Zeilen an die Sammeldatei anzuhängen, mußt du die jeweilige Zeile berechnen.
Beispiel:
2 Dateien mit jeweils 3 Zeilen:
Für Datei 1 gilt: 0 * 3 + OrginalZeile
ergibt: 1, 2 und 3
Für Datei 2 gilt: 1 * 3 + OrginalZeile
ergibt: 4, 5 und 6
In die errechnete Zeile schreibst Du dann die Zeile aus der Orginaldatei.
Ich hoffe, daß ich dir damit helfen konnte.
Gruß
ComputerFee
da die Dateien alle die gleiche Struktur ( gleiche Anzahl an Zeilen ) aufweisen, würde ich folgendermaßen vorgehen:
Du erzeugst einen DateiZaehler, den Du zu Beginn auf 0 initialisierst.
Beim Öffnen einer Datei, erhöhst Du den Zaehler um 1.
Um die Zeilen an die Sammeldatei anzuhängen, mußt du die jeweilige Zeile berechnen.
Beispiel:
2 Dateien mit jeweils 3 Zeilen:
Für Datei 1 gilt: 0 * 3 + OrginalZeile
ergibt: 1, 2 und 3
Für Datei 2 gilt: 1 * 3 + OrginalZeile
ergibt: 4, 5 und 6
In die errechnete Zeile schreibst Du dann die Zeile aus der Orginaldatei.
Ich hoffe, daß ich dir damit helfen konnte.
Gruß
ComputerFee
Antwort 2 von ComputerFee
Hi,
ich bins nochmal.
Mir kam gerade noch eine 2. Idee:
Du merkst Dir immer die Zeile in der Sammeldateo, in die Du gerade schreibst und erhöhst diese dann vor dem nächsten schreiben.
Damit müßte es auch funktionieren.
Gruß
ComputerFee
ich bins nochmal.
Mir kam gerade noch eine 2. Idee:
Du merkst Dir immer die Zeile in der Sammeldateo, in die Du gerade schreibst und erhöhst diese dann vor dem nächsten schreiben.
Damit müßte es auch funktionieren.
Gruß
ComputerFee
Antwort 3 von nighty
hi alle :)
liest beliebig viele dateien ein und liesst spalte a + b aus und fuegt sie in der aktuellen mappe spalte a + b wieder an ,einziges handicap da ja eh nur einmalig gebraucht also nicht so schlimm das bei den auszulesenden dateien eine freie zeile das auslesen der jeweiligen mappe beendet.
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
rem dein pfad der dateien
rem zu beachten das nur auszulesende dateien
rem sich darin befinden sollten
rem keine fehlerroutine praesent
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Workbooks(1).Activate
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = lastcell.Column
b = lastcell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
Do
zaehler1 = zaehler1 + 1
If Workbooks(2).Sheets(1).Cells(zaehler1, 1) <> "" Then
Workbooks(1).Sheets(1).Cells(lzeile + zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler1, 1)
Workbooks(1).Sheets(1).Cells(lzeile + zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler1, 2)
Else
zaehler1 = 0
Exit Do
End If
Loop
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
liest beliebig viele dateien ein und liesst spalte a + b aus und fuegt sie in der aktuellen mappe spalte a + b wieder an ,einziges handicap da ja eh nur einmalig gebraucht also nicht so schlimm das bei den auszulesenden dateien eine freie zeile das auslesen der jeweiligen mappe beendet.
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
rem dein pfad der dateien
rem zu beachten das nur auszulesende dateien
rem sich darin befinden sollten
rem keine fehlerroutine praesent
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Workbooks(1).Activate
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = lastcell.Column
b = lastcell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
Do
zaehler1 = zaehler1 + 1
If Workbooks(2).Sheets(1).Cells(zaehler1, 1) <> "" Then
Workbooks(1).Sheets(1).Cells(lzeile + zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler1, 1)
Workbooks(1).Sheets(1).Cells(lzeile + zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler1, 2)
Else
zaehler1 = 0
Exit Do
End If
Loop
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Antwort 4 von nighty
hi alle :)
mag zwar nicht sooo perfekt sein doch wird es ja nur einmalig gebraucht :)
gruss nighty
mag zwar nicht sooo perfekt sein doch wird es ja nur einmalig gebraucht :)
gruss nighty
Antwort 5 von nighty
hi mckott :)
cool aus berlin :)
bin aus SPANDAU(berlin eingemeindet) :) :)
gruss nighty
cool aus berlin :)
bin aus SPANDAU(berlin eingemeindet) :) :)
gruss nighty
Antwort 6 von nighty
hi alle :)
ein wenig optimiert :)
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Do
zaehler1 = zaehler1 + 1
If Workbooks(2).Sheets(1).Cells(zaehler1, 1) <> "" Then
zaehler2 = zaehler2 + 1
Workbooks(1).Sheets(1).Cells(zaehler2, 1) = Workbooks(2).Sheets(1).Cells(zaehler1, 1)
Workbooks(1).Sheets(1).Cells(zaehler2, 2) = Workbooks(2).Sheets(1).Cells(zaehler1, 2)
Else
zaehler1 = 0
Exit Do
End If
Loop
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
ein wenig optimiert :)
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Do
zaehler1 = zaehler1 + 1
If Workbooks(2).Sheets(1).Cells(zaehler1, 1) <> "" Then
zaehler2 = zaehler2 + 1
Workbooks(1).Sheets(1).Cells(zaehler2, 1) = Workbooks(2).Sheets(1).Cells(zaehler1, 1)
Workbooks(1).Sheets(1).Cells(zaehler2, 2) = Workbooks(2).Sheets(1).Cells(zaehler1, 2)
Else
zaehler1 = 0
Exit Do
End If
Loop
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Antwort 7 von nighty
hi alle :)
so ist fast perfekt :)
automatische abtastung der einlesenden dateien auf ende,es werden nur xls gelesen aus der angegebenen directory beliebig viele bzw. um die 65 535 glaub ich maximum :)
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2,a, alta, lzeile,lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Next zaehler2
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
so ist fast perfekt :)
automatische abtastung der einlesenden dateien auf ende,es werden nur xls gelesen aus der angegebenen directory beliebig viele bzw. um die 65 535 glaub ich maximum :)
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2,a, alta, lzeile,lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Next zaehler2
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Antwort 8 von nighty
hi alle :)
vielleicht hat ja noch einer dazu ideen.sieht irgendwie ungluecklich aus :(
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
gruss nighty
vielleicht hat ja noch einer dazu ideen.sieht irgendwie ungluecklich aus :(
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
gruss nighty
Antwort 9 von mckott
... und das geht! - einwandfrei!
Danke ComputerFee und nighty!
Ich bin echt begeistert! - Mann, spart man sich da eine Arbeit!
nighty - noch eine Frage an den Experten:
bin echt der absolute beginner in Sachen VBA, trotzdem interessiert mich noch - wie müßte das Makro aussehen wenn noch Spalte C und D und... dazukommen würde? Was muß ich da ändern?
Nochmal ein fettes Danke
und ein Lob an die Macher der site - ist ne feine Sache!
cu
mckott
Danke ComputerFee und nighty!
Ich bin echt begeistert! - Mann, spart man sich da eine Arbeit!
nighty - noch eine Frage an den Experten:
bin echt der absolute beginner in Sachen VBA, trotzdem interessiert mich noch - wie müßte das Makro aussehen wenn noch Spalte C und D und... dazukommen würde? Was muß ich da ändern?
Nochmal ein fettes Danke
und ein Lob an die Macher der site - ist ne feine Sache!
cu
mckott
Antwort 10 von ComputerFee
Hallo mckott,
wenn ich das richtig sehe, mußt Du nur die folgende Zeile duplizieren:
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Anschließend bei dem 2. Parameter von Cells die '1' ( steht für 1. Spalte ) in die gewünschte Spalte umbenennen.
Gruß
ComputerFee
wenn ich das richtig sehe, mußt Du nur die folgende Zeile duplizieren:
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Anschließend bei dem 2. Parameter von Cells die '1' ( steht für 1. Spalte ) in die gewünschte Spalte umbenennen.
Gruß
ComputerFee
Antwort 11 von nighty
hi mckott :)
spaltenabtastung mit einbezogen
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2, zaehler3, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = lastcell.Column
b = lastcell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
For zaehler3 = 1 To lspalte
Workbooks(1).Sheets(1).Cells(zaehler1, zaehler3) = Workbooks(2).Sheets(1).Cells(zaehler2, zaehler3)
Next zaehler3
Next zaehler2
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
spaltenabtastung mit einbezogen
gruss nighty
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2, zaehler3, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = "C:\test3"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = lastcell.Column
b = lastcell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
For zaehler3 = 1 To lspalte
Workbooks(1).Sheets(1).Cells(zaehler1, zaehler3) = Workbooks(2).Sheets(1).Cells(zaehler2, zaehler3)
Next zaehler3
Next zaehler2
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Antwort 12 von mckott
du hast es richtig gesehen - das funktioniert!
Danke ComputerFee!
Danke ComputerFee!
Antwort 13 von mckott
Hi nighty!
deins funktioniert auch! Danke auch dir!
deins funktioniert auch! Danke auch dir!