Frage Microsoft Microsoft Office

gelöst Daten aus meheren Sheets in mehreren Dateien sammeln

Sub Zusammenfassen() 

Const sSourcePath = "C:\..........." 'Ordner der Dateien 

Set wbGes = ActiveWorkbook 'aktuelle Mappe und ... 

Set wsZiel = ActiveWorkbook.ActiveSheet '... aktuelle Tabelle zwischenspeichern 

Set fso = CreateObject("Scripting.FileSystemObject") 

Z = 2 'ab Zeile 2 in der Sammeltabelle eintragen 

Application.ScreenUpdating = False 'während der folgenden Aktionen Excel-Bildschirm "einfrieren"; diese Zeile kann auch auskommentiert / entfernt werden 

For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Ordners durchgehen 

    If LCase(fso.GetExtensionName(oFile.Name)) = "tdm" Then 'nur .xls-Dateien bearbeiten; falls "xlsx" bitte anpassen; nur Kleinbuchstaben verwenden 

        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path) 'Datei öffnen 

        For I = 2 To 89 

            Wert = Sheets(I).Range("F5").Copy 'Zelle auslesen und ... 

            wsZiel.Cells(Z, I).Paste '... einfügen  

        Next 

        Z = Z + 1 'Zeilennummer der Zieltabelle für das nächste Einfügen erhöhen 

        wbQuellDatei.Close 'Datei schließen 

    End If 

Next 

Application.ScreenUpdating = True 'Excel-Bildschirmanzeige wieder "auftauen" ;-) 

wsZiel.Activate 'zur Sicherheit Zieltabelle aktivieren 

wbGes.Save 'Sammeldatei speichern 

MsgBox "Fertig." 

End Sub

Sub Umbenennen() 

COMAddIns.Item ("ExcelTDM.TDMAddin") 

Const sSourcePath = "Q:\....." 

For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Quellordners durchgehen 

    If LCase(fso.GetExtensionName(oFile.Name)) = "tdm" Then 'nur .tdm-Dateien bearbeiten, es sind auch noch tdx Files vorhanden 

        Set wbQuellDatei = Object.ImportFile(oFile.Path) 

        Active.Workbook.SaveAs (oFile.Name) 

    End If 

Next 

End Sub