Hallo zusammen,

habe folgenden Code mit den Tipps von Holger zusammengestellt. Beim Öffnen der Tabelle geht eine Userform auf, in der man das Quellverzeichnis auswählt und die Bezeichnung des Zielordners eingibt. Dann klickt man auf einen CommandButton und das Makro "RDB_Copy_Sheet" wird aufgerufen. Siehe Text unten.

Leider passiert nichts nach Eingabe der Daten.

Das Tool läuft durch aber es wird:

1. kein neuer Ordner erstellt

2. keine Datei mit neuem Namen kopiert

-->  Kann mir jemand helfen? Vielen Dank :o)

Sub ORDNER_Click()

  Dim AppShell As Object
  Dim BrowseDir As Variant
  Dim Pfad As String
  Set AppShell = CreateObject("Shell.Application")
  Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
  On Error Resume Next
  Pfad = BrowseDir.items().Item().Path
  If Pfad = "" Then Exit Sub
OrdnerPfad = Pfad



End Sub
---------------------------------------------

Private Sub CommandButton1_Click()
 If UserForm1.OrdnerPfad.Value = "" Then
  
         MsgBox "Bitte Pfad kopieren"
        Exit Sub
           Else
 End If
 
  If UserForm1.NeuerOrdnerName.Value = "" Then
  
         MsgBox "Bitte Ordnernamen eingeben"
        Exit Sub
           Else
 End If
 
Call DateinamenUmbenennen.RDB_Copy_Sheet
 
End Sub

------------------------------------

Option Explicit
 
Sub RDB_Copy_Sheet()

Dim FSO As Object
Dim objFSO As Object
Dim objOrdner As Object
Dim Protokolle_Kurz
Dim g As Object
Dim Pfad As String
Dim fldr As Object

On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.CreateFolder(Pfad & UserForm1.NeuerOrdnerName.Text)

Set FSO = CreateObject("scripting.filesystemobject")
Set fldr = FSO.getfolder(Pfad)
Dim datei, c
Dim NeuerName As String

For Each datei In fldr.Files
    If datei.Name Like "*M6201*" Then
    NeuerName = "A10St1"
    ElseIf datei.Name Like "*M6202*" Then
    NeuerName = "A10St2"
    c = FSO.copyfile(datei, Pfad & NeuerName, True)
    End If
    Next
    
    
MsgBox "Alles läuft durch"
End Sub