AW: Liste mit Pfad in Spalten darstellen
29.01.2019 15:02:39
Sepp
Hallo Filip,
probier mal.
Modul Modul1
Option Explicit
Sub splitPath()
Dim lngIndex As Long, lngFirst As Long, lngRow As Long, strCompare As String
Dim strSheets() As String, rngCopy() As Range, objWS As Worksheet
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Sheets("Tabelle1") 'Tabellenname mit den Pfaden - Anpassen!
.Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Sort .Cells(1, 2), xlAscending, Header:=False
lngFirst = 1
strCompare = Split(.Cells(lngFirst, 2), "\")(4)
For lngRow = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
If Split(IIf(InStr(1, .Cells(lngRow + 1, 2), "\") = 0, "\\\\", "") & .Cells(lngRow + 1, 2), "\")(4) <> strCompare Then
Redim Preserve strSheets(lngIndex)
Redim Preserve rngCopy(lngIndex)
strSheets(lngIndex) = strCompare
Set rngCopy(lngIndex) = .Range(.Cells(lngFirst, 2), .Cells(lngRow, 2))
lngIndex = lngIndex + 1
lngFirst = lngRow + 1
strCompare = Split(IIf(InStr(1, .Cells(lngFirst, 2), "\") = 0, "\\\\", "") & .Cells(lngFirst, 2), "\")(4)
End If
Next
End With
If lngIndex > 0 Then
For lngIndex = 0 To Ubound(strSheets)
If Not SheetExist(strSheets(lngIndex)) Then
Set objWS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
objWS.Name = strSheets(lngIndex)
Else
Set objWS = Sheets(strSheets(lngIndex))
End If
With objWS
.Cells.Clear
rngCopy(lngIndex).Copy .Range("A1")
.Range("A1").CurrentRegion.TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
Space:=False, Other:=True, OtherChar:="\", FieldInfo:=Array(Array(1, 9), Array(2, 9), Array(3, 9), Array(4, 9)), _
TrailingMinusNumbers:=True
.Columns.AutoFit
End With
Next
End If
ErrorHandler:
If Err.Number <> 0 Then
MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "splitPath" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Set objWS = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) As Boolean
Dim wks As Object
On Error GoTo ErrorHandler
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If byCodeName Then
If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function
Else
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
End If
Next
ErrorHandler:
SheetExist = False
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0