Hallo,
ich hab dir mal ein Makro geschrieben.
Vorgehensweise:
- neue Datei "result.csv" erstellen
- VB-Editor Starten (ALT+F11)
- neues Modul erstellen (Symbolleiste, zweites Icon, Modul)
- Makro einfügen
- STRG + S
- ALT + F4
- Menüeintrag Makros wählen
- Makro "import" starten
- Dateien wählen
- warten
- freuen
- Danke sagen
Vorraussetzung:
Die zu kopierenden Daten liegen, wie von dir beschrieben alle in der ersten Spalte der Quelldateien.
Und hier der Übeltäter:
Code:
Sub import()
Dim actualLine As Integer ' aktuelle Zeile
Dim actualRow As Integer ' aktuelle Spalte
Dim Spaltefrei As Boolean ' Prüfbool
actualLine = 1
actualRow = 1
Spaltefrei = False
' Testrutine für aktuelle Einfügepostion
While Spaltefrei = False
If Cells(actualLine, actualRow).Value <> \\"\\" Then
actualRow = actualRow + 1
Else
Spaltefrei = True
End If
Wend
' Dateien wählen
Dim Dateien As Variant
Dim Dateizaehler As Integer
Range(\\"X998\\").Value = \\"\\"
Range(\\"X999\\").Value = \\"\\"
Range(\\"X998\\").Select
Dateien = Application.GetOpenFilename(\\"Alle-Dateien (*.*),*.*,\\", MultiSelect:=True)
On Error GoTo ERRORHANDLER
For Dateizaehler = 1 To UBound(Dateien)
Wert = Dateien(Dateizaehler)
Range(\\"X998\\").Value = Wert
Wertlänge = Len(Wert)
For k = 1 To Wertlänge
Wertrechts = Right(Wert, k)
Slash = Left(Wertrechts, 1)
Select Case Slash
Case Is = \\"\\\"
Wertname = Right(Wert, k - 1)
Range(\\"X999\\").Value = Wertname
GoTo weiter
End Select
Next k
weiter:
Range(\\"X998\\").Select
' Voller Dateiname mit Pfad zum öffnen benötigt
Dim FullFileName As String
FullFileName = Range(\\"X998\\").Value
' Nur Dateiname ohne Pfad zum Wechseln der Dateien in Excel benötigt
Dim JustFileName As String
JustFileName = Range(\\"X999\\").Value
' Kopiervorgang Start
If FullFileName <> \\"\\" And JustFileName <> \\"\\" Then
' Original öffnen
Workbooks.Open Filename:=FullFileName
' erste Spalte markieren und kopieren
Range(\\"A1:A999\\").Select
Selection.Copy
' Zieldatei öffnen
Windows(\\"result.csv\\").Activate
' oberste Zelle in nächster leerer Spalte wählen
Cells(actualLine, actualRow).Select
' Einfügen
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Zwischenablage leeren
Application.CutCopyMode = False
' Reihenzähler + 1
actualRow = actualRow + 1
' Quelldatei aktivieren und schließen
Windows(JustFileName).Activate
Windows(JustFileName).Close
End If
' Kopiervorgang Ende '
' Nächste Datei
Next Dateizaehler
ERRORHANDLER:
Exit Sub
End Sub