从字符串的VBA树视图

Question

我想使用excel vba获取树视图.我有很多String喜欢这个

      /folderOne/fileOne
      /folderTwo/fileThree
      /folderOne/fileTwo
      /folderThree/fileFour
      /folderTwo/subFolderTwo
      /folderThree/subFolderThree/fileFive

我想用vba在excel表中制作树形图.我的要求是

     folderOne
         L fileOne
         L fileTwo
     folderTwo
         L fileThree
     folderThree
         L fileFour
         subFolderThree
               L fileFive

那么我应该如何定义呢？请与我分享一些想法或链接.我对vba很新.

Answer 1

继最近的编辑之后,假设您的工作表看起来像这样.请注意,我创建了一些虚拟样本来演示重复的子文件夹.

/branches/test
/branches/test/link.txt
/branches/test/Test1/link.txt
/branches/testOne
/tags
/trunk
/trunk/test/Test1/link.txt
/trunk/testing
/trunk/testing/link.txt
/trunk/testOne

将以下代码粘贴到模块中并运行它.输出将在新工作表中生成.

代码:

Option Explicit

Const MyDelim As String = "#Sidz#"

Sub Sample()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim MyAr As Variant, TempAr As Variant
    Dim LRow As Long, lCol As Long
    Dim i As Long, j As Long, k As Long, r As Long, Level As Long
    Dim delRange As Range
    Dim sFormula As String, stemp1 As String, stemp2 As String

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    '~~> Set this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Columns(1).Sort Key1:=ws.Range("A1"), _
    Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    MyAr = ws.Range("A1:A" & LRow).Value

    Set wsNew = ThisWorkbook.Sheets.Add

    r = 1: k = 2

    With wsNew
        For i = LBound(MyAr) To UBound(MyAr)
            TempAr = Split(MyAr(i, 1), "/")
            Level = UBound(TempAr) - 1
            .Range("A" & r).Value = TempAr(1)

            For j = 1 To Level
                r = r + 1
                .Cells(r, k).Value = Split(MyAr(i, 1), "/")(j + 1)
                k = k + 1
            Next j
            r = r + 1
            k = 2
        Next

        LRow = LastRow(wsNew)
        lCol = LastColumn(wsNew)

        For i = LRow To 1 Step -1
            If Application.WorksheetFunction.CountA(.Range(.Cells(i, 2), .Cells(i, lCol))) = 0 And _
               Application.WorksheetFunction.CountIf(.Columns(1), .Cells(i, 1)) > 1 Then
                .Rows(i).Delete
            End If
        Next i

        LRow = LastRow(wsNew)

        For i = 2 To LRow
            If .Cells(i, 1).Value = "" And .Cells(i - 1, 1).Value <> "" Then _
            .Cells(i, 1).Value = .Cells(i - 1, 1).Value
        Next i

        For i = 2 To LRow
            For j = 2 To (lCol - 1)
                If .Cells(i, j).Value = "" And .Cells(i - 1, j).Value <> "" And _
                .Cells(i, j - 1).Value = .Cells(i - 1, j - 1).Value Then _
                .Cells(i, j).Value = .Cells(i - 1, j).Value
            Next j
        Next i

        lCol = LastColumn(wsNew) + 1

        For i = 1 To LRow
            sFormula = ""
            For j = 1 To (lCol - 1)
                sFormula = sFormula & "," & .Cells(i, j).Address
            Next j
            .Cells(i, lCol).Formula = "=Concatenate(" & Mid(sFormula, 2) & ")"
        Next i

        .Columns(lCol).Value = .Columns(lCol).Value

        For i = LRow To 2 Step -1
            If Application.WorksheetFunction.CountIf(.Columns(lCol), .Cells(i, lCol)) > 1 Then
                .Rows(i).Delete
            End If
        Next i

        .Columns(lCol).Delete
        lCol = LastColumn(wsNew) + 1
        LRow = LastRow(wsNew)

        For i = LRow To 2 Step -1
            For j = lCol To 2 Step -1
                If .Cells(i, j).Value <> "" And .Cells(i, j).Value = .Cells(i - 1, j).Value Then
                    For k = 2 To (j - 1)
                        stemp1 = stemp1 & MyDelim & .Cells(i, k).Value
                        stemp2 = stemp2 & MyDelim & .Cells(i - 1, k).Value
                    Next k
                    stemp1 = Mid(stemp1, Len(MyDelim) + 1)
                    stemp2 = Mid(stemp2, Len(MyDelim) + 1)

                    If UCase(stemp1) = UCase(stemp2) Then
                        .Range(.Cells(i, 1), .Cells(i, k)).ClearContents
                        Exit For
                    End If
                End If
            Next j
        Next i


        For i = LRow To 2 Step -1
            If Application.WorksheetFunction.CountIf(.Columns(1), _
            .Cells(i, 1).Value) > 1 Then .Cells(i, 1).ClearContents
        Next i

        .Cells.EntireColumn.AutoFit
    End With

LetsContinue:
    Application.ScreenUpdating = True
    Exit Sub
Whoa:
    MsgBox Err.Description
End Sub

Function LastRow(wks As Worksheet) As Long
    LastRow = wks.Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
End Function

Function LastColumn(wks As Worksheet) As Long
    LastColumn = wks.Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
End Function

免责声明:我没有做过任何检查/.请确保数据具有/或添加额外的行以检查是否/使用Instr否则在运行代码时将出现错误.