Ordner in einem Ordner erstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim Pfad$, Ordner$ Pfad = "C:\user\Documents\Zusatzarbeiten" If Not Intersect(Target, Range("C1:C100")) Is Nothing Then Ordner = Left(Target.Offset(0, 1).Value, 3) & "_" & Mid(Target.Offset(0, 1).Value, 4) If Dir(Pfad & Ordner, vbDirectory) = "" Then MkDir Pfad & Ordner End If End If End Sub

Hallo nochmal.
du hast geschrieben:
das wenn eine Zusatzarbeit erfasst wird(N1,N2,N3,usw.)und enter gedrückt wird das sich ein dementsprechender Odner generiert?
- Deshalb hab ich vorgeschlagen über ein Tabellenbatt EREIGNIS zu regeln.
- Excel überwacht dabei Änderungen in den Zellen (also wenn die Zelle nach einer Änderung verlassen wird)
- Dann wird geprüft ob die Änderung in Spalte C in den Zellen 2 bis 100 vorgenommen wurde.
- Dann erst läuft der Rest des Makros ab.
Du musst KEINEN Knopf drücken.
Das makro muss dazu im Projektexplorer in den Codebereich des Tabellenblattes reingesetzt werden.
- Also hier:
Userbild

- dann muss die Datei auch mit Makros als .xlsm abgespeichert werden.
Ich hab die Datei mal so vorbereitet.
https://www.herber.de/bbs/user/86305.xlsm
Gruß UweD

Private Sub Worksheet_Change(ByVal Target As Range) Dim Pfad$, Ordner$, FS, Mfile1$, Mfile2$, SP%, ZE%, DN% SP = 6 ' **** Änderungen in Spalte F werden überwacht ZE = 2 ' **** Änderungen ab Zeile 2 werden überwacht If Not Intersect(Target, Columns(SP)) Is Nothing And Target.Row >= ZE Then Set FS = CreateObject("Scripting.FileSystemObject") Pfad = "C:\user\Documents\Zusatzarbeiten\" Mfile1 = "\Muster1.xlsx" Mfile2 = "\Muster2.xlsx" DN = 4 'Spalte mit Ordnernamen hier D Ordner = Left(Cells(Target.Row, DN).Value, 3) & "_" _ & Mid(Cells(Target.Row, DN).Value, 4) If Dir(Pfad & Ordner, vbDirectory) = "" Then MkDir Pfad & Ordner ' Verzeichnis wird angelegt FS.copyfile Pfad & Mfile1, Pfad & Ordner & Mfile1, True 'Dateicopy FS.copyfile Pfad & Mfile2, Pfad & Ordner & Mfile2, True 'Dateicopy End If End If End Sub

Ich bin es nochmal
Ich würde es so machen und bei Änderung in Spalte F die Spalte D mit ausfüllen lassen....

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Pfad$, Ordner$, FS, Mfile1$, Mfile2$, SP%, ZE%, DN%
SP = 6 ' **** Änderungen in Spalte F werden überwacht
ZE = 2 ' **** Änderungen ab Zeile 2 werden überwacht
If Not Intersect(Target, Columns(SP)) Is Nothing And Target.Row >= ZE Then
If Target.Offset(-1, 0)  "" Then
Set FS = CreateObject("Scripting.FileSystemObject")
Pfad = "C:\user\Documents\Zusatzarbeiten\"
Mfile1 = "\Muster1.xlsx"
Mfile2 = "\Muster2.xlsx"
DN = 4 'Spalte mit Ordnernamen hier D
Ordner = Format(Right(Cells(Target.Row - 1, DN).Value, 3) + 1, """ACT_""000")
Application.EnableEvents = False
Cells(Target.Row, DN).Value = Ordner
Application.EnableEvents = True
If Dir(Pfad & Ordner, vbDirectory) = "" Then
MkDir Pfad & Ordner ' Verzeichnis wird angelegt
FS.copyfile Pfad & Mfile1, Pfad & Ordner & Mfile1, True 'Dateicopy
FS.copyfile Pfad & Mfile2, Pfad & Ordner & Mfile2, True 'Dateicopy
MsgBox "Ordner angelegt" & vbLf & vbLf & "und Dateien kopiert"
Else
MsgBox "Ordner existiert bereits"
End If
Else
MsgBox "Leerzeile vorher darf nicht sein"
End If
End If
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
Application.EnableEvents = True
End Sub

Gruß UweD

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Dim Pfad$, Ordner$, FS, Mfile1$, Mfile2$, SP%, ZE%, DN%, Letzter% SP = 6 ' **** Änderungen in Spalte F werden überwacht ZE = 2 ' **** Änderungen ab Zeile 2 werden überwacht If Not Intersect(Target, Columns(SP)) Is Nothing And Target.Row >= ZE Then If Target.Offset(-1, 0) "" Then Set FS = CreateObject("Scripting.FileSystemObject") Pfad = "C:\user\Documents\Zusatzarbeiten\" Mfile1 = "\Muster1.xlsx" Mfile2 = "\Muster2.xlsx" DN = 4 'Spalte mit Ordnernamen hier D Letzter = IIf(Target.Row = ZE, 0, Right(Cells(Target.Row - 1, DN).Value, 3)) ' _ Letzte Ordner Ordner = Format(Letzter + 1, """ACT_""000") Application.EnableEvents = False Cells(Target.Row, DN).Value = Ordner Application.EnableEvents = True If Dir(Pfad & Ordner, vbDirectory) = "" Then MkDir Pfad & Ordner ' Verzeichnis wird angelegt FS.copyfile Pfad & Mfile1, Pfad & Ordner & Mfile1, True 'Dateicopy FS.copyfile Pfad & Mfile2, Pfad & Ordner & Mfile2, True 'Dateicopy MsgBox "Ordner angelegt" & vbLf & vbLf & "und Dateien kopiert" Else MsgBox "Ordner existiert bereits" End If Else MsgBox "Leerzeile vorher darf nicht sein" End If End If Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear Application.EnableEvents = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Pfad$, Ordner$ Pfad = "C:\Temp\" If Not Intersect(Target, Range("C1:C100")) Is Nothing Then Ordner = Left(Target.Offset(0, 1).Value, 3) & "_" & Mid(Target.Offset(0, 1).Value, 4) If Dir(Pfad & Ordner, vbDirectory) = "" Then ' prüfen, ob Ordner schon besteht If Target.Offset(0, 1).Value "" Then MkDir Pfad & Ordner 'Ordner erstellen MsgBox "Ordner wurde erstellt" End If Else MsgBox "Ordner existiert bereits" End If End If End Sub

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread