AW: Unterverzeichnisse nach Exceltabelle erstellen
04.12.2017 09:30:48
Nepumuk
Hallo Obelix,
Teste mal:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal lpPath As String) As Long
Private Declare Function FormatMessageA Lib "kernel32.dll" ( _
ByVal dwFlags As Long, _
ByRef lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
ByRef Arguments As Long) As Long
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const LANG_NEUTRAL As Long = &H0
Public Sub Ordner_anlegen()
Dim lngColumn As Long, lngLastRow As Long
Dim ialngRow As Long, ialngColumn As Long
Dim lngReturn As Long
Dim strBuffer As String
Dim avntValues As Variant
Dim astrFolder(1 To 7) As String
Dim blnFound As Boolean
For lngColumn = 1 To 7
lngLastRow = WorksheetFunction.Max(lngLastRow, _
Cells(Rows.Count, lngColumn).End(xlUp).Row)
Next
avntValues = Range(Cells(7, 1), Cells(lngLastRow, 7)).Value2
For ialngRow = 1 To UBound(avntValues, 1)
blnFound = False
For ialngColumn = UBound(avntValues, 2) To 1 Step -1
If IsEmpty(avntValues(ialngRow, ialngColumn)) Then
If Not blnFound Then astrFolder(ialngColumn) = vbNullString
Else
astrFolder(ialngColumn) = avntValues(ialngRow, ialngColumn) & "\"
blnFound = True
End If
Next
lngReturn = MakeSureDirectoryPathExists(Join(astrFolder, vbNullString))
If lngReturn = 0 Then
strBuffer = Space$(200)
Call FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, _
Err.LastDllError, LANG_NEUTRAL, strBuffer, 200, ByVal 0&)
strBuffer = Left$(strBuffer, InStrRev(strBuffer, vbNullChar) - 1)
Call MsgBox(strBuffer, vbCritical, "Fehlermeldung")
Exit Sub
End If
Next
Call MsgBox("Erledigt", vbInformation, "Information")
End Sub
Gruß
Nepumuk