我想使用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很新.
继最近的编辑之后,假设您的工作表看起来像这样.请注意,我创建了一些虚拟样本来演示重复的子文件夹.
/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
否则在运行代码时将出现错误.