Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1668to1672
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Liste mit Pfad in Spalten darstellen

Liste mit Pfad in Spalten darstellen
29.01.2019 11:56:17
Filip
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

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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


 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 15:47:20
Filip
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
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 15:48:44
Sepp
Hallo Filip,
und welche Zeile wird markiert?
 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 16:03:12
Filip
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
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 16:03:13
Filip
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
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 16:03:14
Filip
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
Anzeige
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 16:09:23
Sepp
Hallo Filip,
den Tabellennamen hast du angepasst?
 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Liste mit Pfad in Spalten darstellen
29.01.2019 16:01:56
UweD
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
Anzeige

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige