HERBERS Excel-Forum - das Archiv
Thema: Bestimmte Zellen aus mehreren Dateien auslesen...
Bestimmte Zellen aus mehreren Dateien auslesen...
TomTom
Guten Morgen :)
Hab das gerade schon mal geschrieben, aber irgendwie tauchte es nicht in der List auf, also, auf ein neues :D
Folgendes Problem :
Ich möchte aus ca 250 Excel Dokumenten aus einem bestimmten Blatt ( Blattname immer der gleich ) Zellen kopieren und in eine neue Datei einfügen um diese Auszuwerten ( deshalb am besten auch immer mit dem Dateinamen woher die Zahlen kommen ).
Bestimmt hat der ein oder andere hier schon etwas ähnliches dass er bereitstellen könnte, würde mich freuen.
Vielen dank.
AW: Bestimmte Zellen aus mehreren Dateien auslesen...
fcs
Hallo TomTom,
eine Suche in der RECHERCHE hätte bestimmt was verwertbares zum Vorschein gebracht.
Nachfolgen ein Beispiel.
Gruß
Franz
Sub alle_Dateien_Verzeichnis()
Dim dlg As FileDialog
Dim StatusCalc&
Dim varItem, Ext$, Datei$
Dim wkbNeu As Workbook, wkbQuelle As Workbook
Dim wksNeu As Worksheet, wksQuelle As Worksheet, LR&
On Error GoTo Fehler
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set dlg = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen
If dlg.Show = True Then
'Neue Mappe Anlegen
Set wkbNeu = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wkbNeu.Worksheets(1)
With wksNeu
'Spaltentitel
.Cells(1, 1) = "Verzeichnis:"
.Cells(3, 1) = "Dateiname"
.Cells(3, 2) = "Wert 1"
.Cells(3, 3) = "Wert 2"
.Cells(3, 4) = "Wert 3"
'ggf. noch Formate für Spalten vorgeben
End With
For Each varItem In dlg.SelectedItems 'Die Abfrage für den selektierten Eintrag
Ext = "*.xls*" 'Dateiextension ggf. anpassen
Datei = Dir(varItem & "\" & Ext)
Do While Datei <> ""
If LCase(Datei) = LCase(ThisWorkbook.Name) Then GoTo NextDatei
Set wkbQuelle = Workbooks.Open(Filename:=varItem & "\" & Datei, _
ReadOnly:=True, UpdateLinks:=False)
' Set wksQuelle = wkbQuelle.Worksheets(1) '1. Tabelle aus der gelesen wird
Set wksQuelle = wkbQuelle.Sheets("Tabelle1") 'Tabelle aus der gelesen wird
With wksNeu
LR = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'letzte Zeile der Spalte+1
.Cells(LR, 1) = wkbQuelle.Name
'Werte aus Zellen auslesen
.Cells(LR, 2) = wksQuelle.Range("A1") 'hier hinten sind die Zielzellen
.Cells(LR, 3) = wksQuelle.Range("B2") '
.Cells(LR, 4) = wksQuelle.Range("B3") '
'u.s.w
End With
wkbQuelle.Close SaveChanges:=False
Set wkbQuelle = Nothing
NextDatei:
Datei = Dir() 'wählt die nächste Datei
Loop
wksNeu.Cells(1, 2) = varItem
Next
With wksNeu
.Columns.AutoFit
End With
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 1004
If Not wkbQuelle Is Nothing Then wkbQuelle.Close SaveChanges:=False
Resume NextDatei
Case -2147221080 'Automatisierungsfehler
If Not wkbQuelle Is Nothing Then wkbQuelle.Close SaveChanges:=False
Resume NextDatei
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbOKOnly, "Fehler-Makro"
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub
Bestimmte Zellen aus mehreren Dateien auslesen...
TomTom
Guten Morgen :)
Hab das gerade schon mal geschrieben, aber irgendwie tauchte es nicht in der List auf, also, auf ein neues :D
Folgendes Problem :
Ich möchte aus ca 250 Excel Dokumenten aus einem bestimmten Blatt ( Blattname immer der gleich ) Zellen kopieren und in eine neue Datei einfügen um diese Auszuwerten ( deshalb am besten auch immer mit dem Dateinamen woher die Zahlen kommen ).
Bestimmt hat der ein oder andere hier schon etwas ähnliches dass er bereitstellen könnte, würde mich freuen.
Vielen dank.
AW: Bestimmte Zellen aus mehreren Dateien auslesen...
fcs
Hallo TomTom,
eine Suche in der RECHERCHE hätte bestimmt was verwertbares zum Vorschein gebracht.
Nachfolgen ein Beispiel.
Gruß
Franz
Sub alle_Dateien_Verzeichnis()
Dim dlg As FileDialog
Dim StatusCalc&
Dim varItem, Ext$, Datei$
Dim wkbNeu As Workbook, wkbQuelle As Workbook
Dim wksNeu As Worksheet, wksQuelle As Worksheet, LR&
On Error GoTo Fehler
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set dlg = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen
If dlg.Show = True Then
'Neue Mappe Anlegen
Set wkbNeu = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wkbNeu.Worksheets(1)
With wksNeu
'Spaltentitel
.Cells(1, 1) = "Verzeichnis:"
.Cells(3, 1) = "Dateiname"
.Cells(3, 2) = "Wert 1"
.Cells(3, 3) = "Wert 2"
.Cells(3, 4) = "Wert 3"
'ggf. noch Formate für Spalten vorgeben
End With
For Each varItem In dlg.SelectedItems 'Die Abfrage für den selektierten Eintrag
Ext = "*.xls*" 'Dateiextension ggf. anpassen
Datei = Dir(varItem & "\" & Ext)
Do While Datei <> ""
If LCase(Datei) = LCase(ThisWorkbook.Name) Then GoTo NextDatei
Set wkbQuelle = Workbooks.Open(Filename:=varItem & "\" & Datei, _
ReadOnly:=True, UpdateLinks:=False)
' Set wksQuelle = wkbQuelle.Worksheets(1) '1. Tabelle aus der gelesen wird
Set wksQuelle = wkbQuelle.Sheets("Tabelle1") 'Tabelle aus der gelesen wird
With wksNeu
LR = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'letzte Zeile der Spalte+1
.Cells(LR, 1) = wkbQuelle.Name
'Werte aus Zellen auslesen
.Cells(LR, 2) = wksQuelle.Range("A1") 'hier hinten sind die Zielzellen
.Cells(LR, 3) = wksQuelle.Range("B2") '
.Cells(LR, 4) = wksQuelle.Range("B3") '
'u.s.w
End With
wkbQuelle.Close SaveChanges:=False
Set wkbQuelle = Nothing
NextDatei:
Datei = Dir() 'wählt die nächste Datei
Loop
wksNeu.Cells(1, 2) = varItem
Next
With wksNeu
.Columns.AutoFit
End With
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 1004
If Not wkbQuelle Is Nothing Then wkbQuelle.Close SaveChanges:=False
Resume NextDatei
Case -2147221080 'Automatisierungsfehler
If Not wkbQuelle Is Nothing Then wkbQuelle.Close SaveChanges:=False
Resume NextDatei
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbOKOnly, "Fehler-Makro"
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub
Excel-Beispiele