Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Liste mit Pfad in Spalten darstellen


Betrifft: Liste mit Pfad in Spalten darstellen von: Filip
Geschrieben am: 29.01.2019 11:56:17

Hallo,

ich habe folgende Tabelle von B1 beginnend:

\\Subject\connection\1_System\A4A_FälleI_1\MCIConned
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\1 UI
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\2 MI
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\3 wat
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\4 mote
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\5 Lesserned
\\Subject\connection\1_System\A4A_FälleI_1\MCIConned\6 KPI
\\Subject\connection\1_System\A4A_FälleI_1\MCIConnected
\\Subject\connection\1_System\A4A_FälleI_1\MCIConnected \1 UI
\\Subject\connection\1_System\A4A_FälleI_1\MCIConnected \2 MI
...
...
...

Die Liste geht über 5000 Zeilen.
Ich möchte nun jeden einzelnen Pfad in Spalten splitten.
Folgendermaßen wäre es optimal:

A B C D
1 1_System A4A_FälleI_1 MCIConned

2 1_System A4A_FälleI_1 MCIConned 1 UI

3 1_System A4A_FälleI_1 MCIConned 2 UI

4 1_System A4A_FälleI_1 MCIConned 3 wat

usw..

Das ganze wünsche ich mir gruppiert in Tabellen, wobei die Tabelle nach der 3. Komponente vom Pfad benannt werden soll. In meinem Fall wäre der nächste Tabellenname: 1_System

Ist das per VBA machbar?

Danke schonmal & Gruß,
Filip

  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Sepp
Geschrieben am: 29.01.2019 15:02:39

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





 ABCDEF
1Gruß Sepp
2
3



  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Filip
Geschrieben am: 29.01.2019 15:47:20

Hallo Sepp,

vielen Dank für die Hilfe, aber es kommt die Fehlermeldung:
Fehler in Modul1

Prozedur: splitPath
Nummer:9
Meldung: INdex ausßerhalb des gültigen Bereichs

Viele Grüße,
Filip


  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Sepp
Geschrieben am: 29.01.2019 15:48:44

Hallo Filip,

und welche Zeile wird markiert?


 ABCDEF
1Gruß Sepp
2
3



  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Filip
Geschrieben am: 29.01.2019 16:03:12

Hallo Sepp,

im VBA Modul wird keine Zeile markiert.
Die Fehlermeldung popt in der Excel-Tabelle auf.
Nachdem man auf "OK" klickt, verschwindet die Fehlermeldung, aber es passiert nichts weiteres.

Viele Grüße,
Filip


  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Filip
Geschrieben am: 29.01.2019 16:03:13

Hallo Sepp,

im VBA Modul wird keine Zeile markiert.
Die Fehlermeldung popt in der Excel-Tabelle auf.
Nachdem man auf "OK" klickt, verschwindet die Fehlermeldung, aber es passiert nichts weiteres.

Viele Grüße,
Filip


  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Filip
Geschrieben am: 29.01.2019 16:03:14

Hallo Sepp,

im VBA Modul wird keine Zeile markiert.
Die Fehlermeldung popt in der Excel-Tabelle auf.
Nachdem man auf "OK" klickt, verschwindet die Fehlermeldung, aber es passiert nichts weiteres.

Viele Grüße,
Filip


  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: Sepp
Geschrieben am: 29.01.2019 16:09:23

Hallo Filip,

den Tabellennamen hast du angepasst?


 ABCDEF
1Gruß Sepp
2
3



  

Betrifft: AW: Liste mit Pfad in Spalten darstellen von: UweD
Geschrieben am: 29.01.2019 16:01:56

Hallo

auch von mir eine Lösung.

Wichtig: Überschrift ggf einfügen

Option Explicit

Sub Aufteilen()
    Dim TB1, TB2, LR1 As Long, LC As Integer, i As Long
    Dim Arr, LRTmp As Integer, SP As Integer, Z1 As Integer
    Dim TTop As Integer, Zelle As Integer
    Set TB1 = Sheets("Tabelle1")
    SP = 2
    Z1 = 2 'Überschrift muss vorhanden sein 
    
    LR1 = TB1.Cells(TB1.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
    
    With TB1
        'aufsplitten 
        .Columns(SP).TextToColumns Destination:=.Cells(1, SP), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="\", FieldInfo:=Array(Array(1, 9), Array(2, 9), Array(3, 9), Array(4, 9), Array(5, _
            1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
    
        'Ermittlung Unterschiedliche Systeme; Temporär merken; durch Duplikate entfernen 
        LC = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1 'erste freie Spalte des gesamten Blattes 
        .Columns(SP).Copy .Columns(LC)
        .Columns(LC).RemoveDuplicates Columns:=1, Header:=xlNo

        'Array bilden 
        LRTmp = .Cells(.Rows.Count, LC).End(xlUp).Row 'letzte Zeile der Spalte 
        Arr = .Cells(1, LC).Resize(LRTmp, 1).Value
        
        'Tmp löschen 
        .Columns(LC).Delete xlLeft
        
        'Filtern 
        If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten 
        .Columns(SP).AutoFilter
        
        For Zelle = Lbound(Arr) To Ubound(Arr)
            If Arr(Zelle, 1) <> "" Then
                .Columns(SP).AutoFilter Field:=1, Criteria1:=Arr(Zelle, 1)
                
                'neues Blatt erstellen 
                Set TB2 = Sheets.Add(After:=Sheets(Sheets.Count))
                TB2.Name = Arr(Zelle, 1)
                
                'Kopieren 
                .UsedRange.Copy TB2.Cells(1, SP)
            End If
    
        Next
        .AutoFilterMode = False
        
    End With
End Sub

LG UweD


Beiträge aus dem Excel-Forum zum Thema "Liste mit Pfad in Spalten darstellen"