mehrere Exceldateien in eine Excel Datei zusammenfassen

Hallo alle zusammen,

habe folgebdes Problem, versuche es kurz zusammenzufassen.

habe ca. 370 Excel Dateien die ich gerne zu einer machen will, um die später besser auswerten zu können.
Die Dateinamen sind wie folgt aufgebaut: 151~0006@284774.xls, 151~0007@284774.xls, 151~0008@284774.xls usw. alle Dateien sind gleich aufgebaut und von jeder datei bräuchte ich die Zelleninhalte von C54:C332 und, um die Datensätze wieder identifizieren zu können die Zelle B9, die über jeden Datesatz stehen soll. Die ich aber schon manuell eingetragen habe, sollen aber trotzdem mitgeschrieben werden, falls man Nachforschung betreiben möchte/muss.

das. Beispiel unten haut leider nicht ganz hin, da er die datensätze durcheinander kopiert und ich die später nicht mehr identifizieren kann.


Sub Makro1()


Dim Rohdaten(36) As String
Dim AnzahlDateien
Dim ZuÖffnendeDateien, W, Pfad, excelMesswerteDate

ZuÖffnendeDateien = Application.GetOpenFilename("MPT Meßwerte (*.xls), *.xls", _
, "MPT .xls-Datei auswählen", , True)

If IsArray(ZuÖffnendeDateien) Then
For Each W In ZuÖffnendeDateien
AnzahlDateien = AnzahlDateien + 1

For j = 1 To Len(W)
If Left(Right(W, j), 1) = Application.PathSeparator Then
Exit For
Else
End If

Next j

Rohdaten(AnzahlDateien) = Right(W, j - 1)
Pfad = Left(W, Len(W) - Len(Rohdaten(AnzahlDateien)))
Rohdaten(AnzahlDateien) = _
Left(Rohdaten(AnzahlDateien), Len(Rohdaten(AnzahlDateien)) - 4)

Next W

Else

End If

ThisWorkbook.Activate
Sheets.Add
ActiveSheet.Name = "Tabelle1"


For k = 1 To AnzahlDateien


excelMesswerteDatei = Pfad & Rohdaten(k) & ".xls"


Workbooks.OpenText Filename:= _
excelMesswerteDatei _
, Origin:=xlWindows, StartRow:=54, DataType:=xlDelimited, TextQualifier _
:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _
False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array _
(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8 _
, 1)), DecimalSeparator:=".", ThousandsSeparator:=" ", TrailingMinusNumbers:=False


Range("C54:C332").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Tabelle1").Select
Cells(2, k + 1).Select
ActiveSheet.Paste


Next k
End Sub


Für eure Unterstützung wäre ich sehr dankbar...

Dim Rohdaten(36) As String

Dim Rohdaten(250) As String

Dim Rohdaten(36) As String
> 

Dim Rohdaten(250) As String
> 

Range("C54:C332").Select  
Selection.Copy
ThisWorkbook.Activate
Sheets("Tabelle1").Select  
Cells(2, k + 1).Select
ActiveSheet.Paste

<b>ID = Range("B9").Value</b>  
Range("C54:C332").Select  
Selection.Copy
ThisWorkbook.Activate
Sheets("Tabelle1").Select  
Cells(2, k + 1).Select
ActiveSheet.Paste
<b>Cells(1, k + 1).Value = ID</b>

Sub Zusammenfassen()

Const sSourcePath = "D:\Datensammlung"  

Set wbGes = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")  

C = 2 '(ab Spalte B in der Sammeltabelle eintragen)  

For Each oFile In fso.GetFolder(sSourcePath).Files
    'nur .xls-Dateien bearbeiten  
    If LCase(Right(oFile.Name, 4)) = ".xls" Then  
        Application.Workbooks.Open (oFile.Path)
        ID = ActiveWorkbook.Worksheets(1).Range("B9").Value  
        aTemp = ActiveWorkbook.Worksheets(1).Range("C54:C332")  
        ActiveWorkbook.Close
        wbGes.Worksheets(1).Cells(1, C).Value = ID
        wbGes.Worksheets(1).Range(Cells(2, C), _
            Cells(2 + UBound(aTemp) - 1, C)) = aTemp
        C = C + 1
    End If
Next 'Datei  
wbGes.Worksheets(1).Activate
'Gesamt-Datei speichern  
wbGes.Save
MsgBox "Fertig."  
End Sub

Cells(1, k + 1).Value = "Y" & CStr(ID)  

wbGes.Worksheets(1).Cells(1, C).Value = <b>"Y" & CStr(ID)</b>  

aTemp = ActiveWorkbook.Worksheets(1).Range(Cells(1, 1), Cells(2042, 4)).Value