Excel Dateien auslesen und in eine neue überführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
musst du mal probieren.
Die Pfade musst du anpassen nach deinen Bedürfnissen

Sub Dateien_in_eine_Tabelle_zusammenfuehren2()
Dim myFso As Object
Dim myFld As Object
Dim Exfiles As Object
Dim xlFile As Object
Dim wbMainBook As Workbook
Dim wbDataBook As Workbook
Dim iCounter As Integer
'Kann aktiviert werden
'Application.DisplayAlerts = False
'Sollte aktiviert werden wegen Bildschirmflackern
'Application.ScreenUpdating = False
'Erstellt neue Mappe für die Datenausgabe
Set wbMainBook = Workbooks.Add
'Zeilenzähler initialisieren
iCounter = 1
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myFld = myFso.GetFolder("D:\DeinFolder")
Set Exfiles = myFld.Files
For Each xlFile In Exfiles
    'Prüfen auf Dateinamen
    If LCase(Right(xlFile.Name, 3)) = "xls" And Right(xlFile.Name, 4) = "ab00" Then
        'Zuweisen der Variablen
        Set wbDataBook = Workbooks.Open(xlFile.path)
        'Kopieren
        wbDataBook.Worksheets("Kopfdaten").Range("C21").Copy _
            Destination:=wbMainBook.Worksheets(1).Cells(iCounter, 1)
        wbDataBook.Worksheets("Kopfdaten").Range("F19:F20").Copy _
            Destination:=wbMainBook.Worksheets(1).Cells(iCounter, 2)
        'Zeilenzähler hochsetzen
        iCounter = iCounter + 1
        'Geöffnete Mappe schliessen
        wbDataBook.Close
        'Variable leeren
        Set wbDataBook = Nothing
    End If
Next
'Speichert die Zusammengefasste Tabelle
wbMainBook.SaveAs "d:\Deinfolder\All_Data.xls"
'Variable leeren
Set wbMainBook = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Gruss Rainer

shit...Ramses war schneller :-)
Hallo Namensvetter :-)
Auch ich möchte einen Lösungsvorschlag beitragen.


Private Sub Workbook_Open()
Dim Datei As String
Dim Zeile As Integer
'eine neue Datei wird geöffnet für die Datenzusammenfassung
Workbooks.Add
'es werden Überschriften eingetragen, und die Zellen werden Fett formatiert und die Spalte wird verbreitert
With Sheets(1)
.Range("A1").Value = "Überschrift C21 aus Kopfdaten"
.Range("B1").Value = "Überschrift F19 aus Druck"
.Range("C1").Value = "Überschrift F20 aus Druck"
.Range("A1:C1").Font.Bold = True
.Range("A1:C1").Columns.AutoFit
End With
'der Variablen Datei wird der erset Dateiname mit "ab00" zugewiesen
Datei = Dir(ThisWorkbook.Path & "\ab00*.xls")
Zeile = 2
'in diesem Block (Do Until...Loop) wird jede Datei mit "ab00" geöffnet, und die Daten werden ausgelesen und in die Zieltabelle eingetragen
Do Until Datei = ""
Workbooks.Open ThisWorkbook.Path & "\" & Datei
Workbooks(2).Sheets(1).Range("A" & Zeile).Value = Workbooks(3).Sheets("Kopfdaten").Range("C21").Value
Workbooks(2).Sheets(1).Range("B" & Zeile).Value = Workbooks(3).Sheets("Druck").Range("F19").Value
Workbooks(2).Sheets(1).Range("C" & Zeile).Value = Workbooks(3).Sheets("Druck").Range("F20").Value
Workbooks(3).Close savechanges:=False
Zeile = Zeile + 1
Datei = Dir
Loop
'die Zieltabelle wird unter dem Namen "überführte Daten.xls" im gleichen Verzeichnis der Ursprungstabellen gespeichert
Workbooks(2).SaveAs (ThisWorkbook.Path & "\überführte Daten.xls")
End Sub

Hier kannst Du Dir meine Bsp-Datei herunterladen
https://www.herber.de/bbs/user/4281.xls
Konnte ich denn auch helfen?
Ciao
Thorsten

Beliebteste Forumthreads (12 Monate)

Excel Dateien auslesen und in eine neue überführen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel Dateien auslesen und in eine neue überführen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread