[[EID]-Mr.GiZMO]

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:

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