AW: Zellenname als Windows-Ordnernahme ausgeben
15.11.2012 07:49:54
Tino
Hallo,
kannst mal dies versuchen.
In der Zeile strPath = "G:\TestOrdner" kannst Du den Pfad vorgeben.
Es werden alle markierten Zellen durchlaufen.
Wenn ein Ordner nicht angelegt werden kann, wird eine Fahlerlister erstellt.
Getestet unter, Win7(32Bit) mit xl2007!
Option Explicit
Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long
Sub OrdnerAnlegen()
Dim varData, varPath, arrFehler()
Dim strPath$, sTmpPath$
Dim lngPath&, nCountF&
Dim oWS As Worksheet
'hier Pfad angeben
strPath = "G:\TestOrdner"
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\")
For Each varData In Selection.Areas
For Each varPath In varData
If varPath <> "" Then
sTmpPath = varPath
If Left$(sTmpPath, 1) = "\" Then sTmpPath = Mid$(sTmpPath, 2, Len(sTmpPath))
If Right$(sTmpPath, 1) <> "\" Then sTmpPath = sTmpPath & "\"
sTmpPath = strPath & sTmpPath
lngPath = apiCreateFullPath(sTmpPath)
If lngPath = 0 Then
Redim Preserve arrFehler(nCountF)
arrFehler(nCountF) = varPath
nCountF = nCountF + 1
End If
End If
Next varPath
Next varData
If nCountF > 0 Then
If MsgBox("Es wurden nicht alle Ordner angelegt!" & vbCr & _
"Soll eine Liste der Fehler ausgegeben werden?", vbQuestion + vbYesNo) = vbYes Then
Set oWS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
oWS.Cells(1, 1) = "Fehler Pfad"
oWS.Cells(1, 1).Font.Bold = True
oWS.Cells(2, 1).Resize(nCountF) = Application.Transpose(arrFehler)
oWS.Columns(1).AutoFit
End If
End If
End Sub
Gruß Tino