Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1420to1424
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

Bestimmte Zellen aus mehreren Dateien auslesen...

Bestimmte Zellen aus mehreren Dateien auslesen...
23.04.2015 08:35:21
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.

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bestimmte Zellen aus mehreren Dateien auslesen...
23.04.2015 18:48:28
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

Anzeige

315 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige