我想用Excel vba.I讓樹視圖有很多字符串喜歡這個VBA樹視圖從字符串
/folderOne/fileOne
/folderTwo/fileThree
/folderOne/fileTwo
/folderThree/fileFour
/folderTwo/subFolderTwo
/folderThree/subFolderThree/fileFive
，我想提出使用vba.My需求樹教職員在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
粘貼模塊在下面的代碼並運行它。輸出將在新的工作表中生成。
CODE：
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增加一行來檢查/否則在運行代碼時會出現錯誤。
+1令人印象深刻。您可能想要添加Application.Screenupdating = False/True以獲得更快的代碼流，如果在分割之前存在「/」可能需要檢查「/」。 –
@PradeepKumar：好點:)我添加了ScreenUpdating部分。關於'/'的檢查，增加了免責聲明：p –
+1好的解決方案Siddharth。美學上，你可能會添加樹輪廓。:-) –
確定假設你的數據在A列，試試這個：
Option Explicit
Sub test()
Dim rng As Range, cel As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1", _
ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Address)
rng.TextToColumns rng.Range("A1"), , , , , , , , True, "/"
Set rng = ThisWorkbook.Sheets("Sheet1").Range("B1", _
ThisWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Address)
For Each cel In rng
If cel.Row <> 1 Then If cel.Value = cel.Offset(-1, 0).Value Then cel.ClearContents
Next
End Sub
希望這得到是你開始莫名其妙。
+ 1很好的做法，但需要更多的修剪:)如果有多一行說'/ folderThree/subFolderThree/fileSix'後面的代碼將失敗'/ folderThree/subFolderThree/fileFive'然後像你說的這將得到OP啓動:) –
[另一]（http://www.vbforums.com/showthread.php?583663-RESOLVED-Complication-with-Treeview）有趣的方式來做到這一點:) –
@SiddharthRout哈哈哈，當我測試時，我想到也是如此。還有，我不知道OP是否像這樣的樹。我的意思是說它的方式是別的。就像'Pivot'彙總數據一樣。或者你如何安排它在你的職位LOL。 – L42
這是我的東西。
雖然你自己仍然需要做一些工作，你可以輕鬆做到。 假設您的文件路徑位於「A」列中。您將不得不適當地更改代碼以滿足您的需求。在我的代碼中，我剛剛編碼了哪些單元格以拾取顯示在樹視圖中。您將需要根據您的需求進行修改。
聲明：
下面提供的解決方案僅用於個人使用。如果您計劃分發您的Excel文件，則此解決方案不可行。此外，你的電腦應該有COMCTL32.OCX註冊（應該是，如果你有安裝VB6運行時）
步驟：
把你的數據在 「A」 柱。 （測試我的代碼。以後修改根據自己的需要） 
轉到Developer選項卡，然後單擊Design Mode。然後點擊工具欄上的Insert按鈕。 
單擊more...圖標。一個在右下角。這將打開More Controls對話框。
尋找Microsoft TreeView Control, Version 6。選擇它並點擊確定。 
TreeView控件將被添加到工作表。雙擊它，它將打開代碼窗口。
將以下代碼粘貼到代碼窗口中。
（與你的TreeView控件的名稱的代碼替換TreeView31）
Sub Button1_Click()
LoadTreeView TreeView31
End Sub
Sub Button2_Click()
TreeView31.Nodes.Clear
End Sub
Sub LoadTreeView(TV As TreeView)
Dim i As Integer, RootNode As Node
TV.Nodes.Clear
Set RootNode = TV.Nodes.Add(, , "ROOT", "ROOT")
RootNode.Expanded = True
For i = 1 To 5
AddNode TV, RootNode, Cells(i, 1)
Next
End Sub
Private Sub AddNode(TV As TreeView, RootNode As Node, Path As String)
Dim ParentNode As Node, NodeKey As String
Dim PathNodes() As String
On Error GoTo ErrH
PathNodes = Split(Path, "/")
NodeKey = RootNode.Key
For i = 1 To UBound(PathNodes)
Set ParentNode = TV.Nodes(NodeKey)
NodeKey = NodeKey & "/" & PathNodes(i)
TV.Nodes.Add ParentNode, tvwChild, NodeKey, PathNodes(i)
ParentNode.Expanded = True
Next
Exit Sub
ErrH:
If Err.Number = 35601 Then
Set ParentNode = RootNode
Resume
End If
Resume Next
End Sub
6.開發商選項卡上，再次單擊工具欄上的按鈕Insert並添加Button控制（一個在左上角）。將它添加到你的工作表中，它會自動彈出Assign Macro對話框。從列表中選擇Sheet1.Button1_Click。並將標題重命名爲Fill TreeView（或您認爲適合您的任何內容）。 
7.添加另一個按鈕。這一次與Sheet1.Button2_Click結合它和它的標題設置爲Clear
8.再次單擊工具欄上的按鈕Design Mode將其關閉。
9.現在點擊Fill TreeView它應該填充你的文件名到TreeView中。 
Pradeep，我已經建議了Treeview版本:)請參閱L42的帖子下的評論。 Treeview不是一個自由的控件;） –
正在尋找具有層次結構的東西來嘗試一些遞歸的東西。這是我對這個問題的解決方案：
Sub callTheFunction()
'"A1:A6" = range with the values, "A10" = first cell of target range, "/" = delimiter
Call createHierarchy(Range("A1:A6"), Range("A10"), "/")
End Sub
Sub createHierarchy(rngSource As Range, rngTarget As Range, strDelimiter As String)
Dim dic As Object, rng As Range
Set dic = CreateObject("scripting.dictionary")
For Each rng In rngSource
addValuesToDic dic, Split(rng.Value, strDelimiter), 1
Next
writeKeysToRange dic, rngTarget, 0, 0
End Sub
Sub addValuesToDic(ByRef dic As Object, ByVal avarValues As Variant, i As Long)
If Not dic.Exists(avarValues(i)) Then
Set dic(avarValues(i)) = CreateObject("scripting.dictionary")
End If
If i < UBound(avarValues) Then addValuesToDic dic(avarValues(i)), avarValues, i + 1
End Sub
Sub writeKeysToRange(dic As Object, rngTarget As Range, _
ByRef lngRowOffset As Long, ByVal lngColOffset As Long)
Dim varKey As Variant
For Each varKey In dic.keys
'adds "L " in front of file if value is like "file*"
rngTarget.Offset(lngRowOffset, lngColOffset) = IIf(varKey Like "file*", "L " & varKey, varKey)
lngRowOffset = lngRowOffset + 1
If dic(varKey).Count > 0 Then
writeKeysToRange dic(varKey), rngTarget, lngRowOffset, lngColOffset + 1
End If
Next
End Sub
你想要你的樹在一列嗎？或在不同的列？ – L42
@ L42不同列 –
現在就進行測試。我在最近的修改後更新了我的答案。 –