Hallo zusammen,

ich bin absoluter Anfänger im Bereich VBA bzw Excel Makros programmieren und soll jetzt für meine Firma ein Excel Makro programmieren welches ausgewählte Dateien in ein Arbeitsblatt zusammenfügt (das funkioniert schon) jetzt gibt es aber einen Verbesserungsvorschlag (siehe unten anbei):

1. Kopierte bzw ausgewählte Datei(en) in Unterordner "archiv" verschieben, sprich in dem Ornder wo ich meine Dateien auswähle, soll beim ersten mal wo ich die Dateien zusammengefügt habe ein Ordner namens "Archiv" erstellt werden wo anschließend immer alle ausgewählten Dateien hineinverschoben werden.
   
   Hier ist noch mein Code:

   Sub CSV_Import2()
   Dim ws As Worksheet
   Dim i As Integer
   Dim strFile As Variant
   Set ws = ActiveWorkbook.Sheets("Zwischenspeicher") 'set to current worksheet name
   
   ws.Columns.NumberFormat = "@"
   
   strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...", , True)
   
   For i = 1 To UBound(strFile)
   ws.UsedRange.Delete
   
   With ws.QueryTables.Add(Connection:="TEXT;" & strFile(i), Destination:=ws.Range("A1"))
   .PreserveFormatting = True
   
   .TextFileParseType = xlDelimited
   '.TextFileCommaDelimiter = True
   .TextFileOtherDelimiter = ";"
   .TextFileDecimalSeparator = "."
   .Refresh
   End With
   
   RemoveHeaderData
   CopyFromZwischenspeicherSheetToEndergebnis
   Next i
   
   Worksheets("Zwischenspeicher").Range("A1:AZ100000").Clear
   'ActiveWorkbook.Sheets("Endergebnis").Activate
   ActiveWorkbook.Save
   
   
   End Sub
   Sub RemoveHeaderData()
   Dim index As Integer
   Dim ws As Worksheet
   Dim done As Boolean
   Dim colCount As Long
   
   index = 1
   Set ws = ActiveWorkbook.Sheets("Zwischenspeicher")
   
   Do While done = False
   
   colCount = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
   If colCount > 5 Then
   done = True
   Else
   ws.Rows(1).EntireRow.Delete
   End If
   
   Loop
   
   End Sub
   Sub CopyFromZwischenspeicherSheetToEndergebnis()
   Dim ws_t As Worksheet
   Dim ws_e As Worksheet
   Dim i As Long
   
   Set ws_t = ActiveWorkbook.Sheets("Zwischenspeicher")
   Set ws_e = ActiveWorkbook.Sheets("Endergebnis")
   
   i = ws_e.UsedRange.Rows.Count
   If i = 1 Then i = 0
   
   
   ws_t.UsedRange.Copy
   ws_e.Cells(i + 1, 1).PasteSpecial xlPasteValues
   
   End Sub
   Sub ArbeitsmappeSpeichern()
   
   ActiveWorkbook.SaveAs (ThisWorkbook.Path & ".xlsx")
   ActiveWorkbook.Close
   
   End Sub
   
   

    

Falls irgendetwas unverständlich ist bitte einfach schreiben.

Danke im Vorraus :)

MfG

Christoph 

PS: Ich benutze Windows 10 Enterprise und Office 365