ich habe unten ein Code, der mir verschiedene Daten aus mehreren Dateien eines Verzeichnises herausliest. Soweit so gut, das funzt ganz anständig.
Nun möchte ich aber die Daten nicht untereinander auflisten, sondern nebeneinander, d.h. jeder datensatz in einer neuen spalte.
Ich habe probiert und probiert, aber irgendwie bringe ich es nicht hin und bin schon nahe am verzweifeln... kann mir jemand helfen?
Besten Dank an alle, die Geduld mit lernwilligen Anfängern haben!
Sub Frequenzenauslesen()
' Übernahme von Daten aus mehreren Blättern auf ein Tabellenblatt
Dim Blatt As Workbook, wb1 As Workbook, wks1 As Worksheet, Steuerung As Worksheet
Dim Pfad As String, Dateiname As String, wks2 As Worksheet, Reihe As Long
Dim Zeile1 As Long, Zeile As Long, Spalte As Integer
Set Steuerung = ThisWorkbook.Sheets("Tabelle1")
'Neue Arbeitsmappe anlegen
Set wb1 = Workbooks.Add
'Überzählige Blätter löschen
Application.DisplayAlerts = False
For i = wb1.Sheets.Count To 2 Step -1
wb1.Sheets(i).Delete
Next
Application.DisplayAlerts = True
Pfad = Steuerung.Range("B8").Value ' Verzeichnis der Blätter
Zeile1 = 1 '1. Zeile ab der Daten in neue Tabelle eingefügt werden sollen
Zeile = Zeile1
Set wks1 = wb1.Sheets(1)
Application.ScreenUpdating = False
Dateiname = Dir(Pfad & "\*.XLS")
Do Until Dateiname = ""
Set Blatt = Workbooks.Open(Pfad & "\" & Dateiname)
Application.StatusBar = "Datei " & Blatt.Name & " wird eingelesen"
' Daten im Blatt kopieren und in neues Blatt einfügen
Set wks2 = Blatt.Worksheets(1)
If Zeile = Zeile1 Then ' Spaltenbreiten formatieren bevor Daten aus 1. Blatt kopiert werden
For Spalte = 1 To 13 'Spalten A bis M
wks1.Cells(1, Spalte).ColumnWidth = wks2.Cells(1, Spalte).ColumnWidth
Next
End If
For Reihe = 28 To 56
If Application.WorksheetFunction.CountA(wks2.Range(wks2.Cells(Reihe, "X"), wks2.Cells(Reihe, "X"))) > 0 Then
wks2.Range(wks2.Cells(Reihe, "X"), wks2.Cells(Reihe, "X")).Copy wks1.Cells(Zeile, 1)
Zeile = Zeile + 1
End If
Next Reihe
Blatt.Close Savechanges:=False
Dateiname = Dir ' Nächste Datei
Loop
Application.StatusBar = False
Application.ScreenUpdating = False
'nun die anderen anhängen
ActiveWorkbook.SaveAs Filename:=Pfad & "\" & "ZUS" & [A2].Text & ".xls"
End Sub