AW: Erweiterung eines Codes
14.04.2015 12:03:50
Nepumuk
Hallo,
würde ich so machen:
Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
Private Declare PtrSafe Function CopyFileA Lib "kernel32.dll" ( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Const FOLDER_PATH As String = "G:\Eigene Dateien\" ' "C:\users\user\Documents\handover\"
Const FILE_NAME As String = "Mappe1.xlsx" ' "Final_Handover_.xlsx"
Const TP_COLUMN As Long = 6 ' **** Änderungen in Spalte F werden überwacht
Const FIRST_ROW As Long = 2 ' **** Änderungen ab Zeile 2 werden überwacht
Const FOLDER_COLUMN As Long = 4 'Spalte mit Ordnernamen hier D
On Error GoTo Fehler
Dim lngLastNumber As Long, lngReturn As Long
Dim strFolder As String
If Not Intersect(Target, Columns(TP_COLUMN)) Is Nothing And Target.Row >= FIRST_ROW Then
If Not IsEmpty(Target.Offset(-1, 0).Value) Then
'Letzte Ordner
lngLastNumber = IIf(Target.Row = FIRST_ROW, 0, _
Right$(Cells(Target.Row - 1, FOLDER_COLUMN).Value, 3))
'Neuer Ordner
strFolder = "TP_Handover_" & Format(lngLastNumber + 1, "000")
'Neuen Ordner eintragen
Application.EnableEvents = False
Cells(Target.Row, FOLDER_COLUMN).Value = strFolder
Application.EnableEvents = True
strFolder = strFolder & "\"
'Prüfen ob neuer Ordner schon existiert
If Dir(FOLDER_PATH & strFolder, vbDirectory) = vbNullString Then
' Verzeichnis wird angelegt
lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & strFolder)
If lngReturn = 0 Then
Err.Raise Number:=vbObjectError + 1, Description:="Fehler beim Erstellen des Ordners"
Else
'Dateicopy
lngReturn = CopyFileA(FOLDER_PATH & FILE_NAME, FOLDER_PATH & strFolder & FILE_NAME, 1)
If lngReturn = 0 Then
Err.Raise Number:=vbObjectError + 2, Description:="Fehler beim Kopieren der Datei"
Else
MsgBox "Ordner angelegt" & vbLf & vbLf & "und Dateien kopiert", vbInformation, "Information"
'Mappe öffnen
Workbooks.Open Filename:=FOLDER_PATH & strFolder & FILE_NAME
End If
End If
Else
Err.Raise Number:=vbObjectError + 3, Description:="Ordner existiert bereits"
End If
Else
Err.Raise Number:=vbObjectError + 4, Description:="Leerzeile vorher darf nicht sein"
End If
End If
Exit Sub
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description, vbCritical, "Fehlermeldung"
Application.EnableEvents = True
End Sub
Gruß
Nepumuk