楼主
xmyjk |
Q:如何使用vba窗体，显示同文件夹下各分表的工作簿的所有工作表的树形结构，并实现单击树形结构的表名导入该表?
A:借用了wise版的一个窗体，程序如下，请下载下来在硬盘解压缩后运行：
使用方法：点击按钮生成树形的文件目录窗体，双击目录的工作薄名称，展开所拥有的工作表树形，单击工作表名称，导入该表到汇总表中。
- Private Sub UserForm_Initialize()
- Dim myPath As String, myFile As String, Wb As Workbook, i As Integer, arr(), brr(), m&, crr(), sh As Worksheet, x&
- Dim bnode(), j&, snode(), key As String
-
- Application.ScreenUpdating = False
- myPath = ThisWorkbook.Path & "\"
- myFile = Dir(myPath & "*.xls?")
- Do While myFile <> ""
- If myFile <> ThisWorkbook.Name Then
- m = m + 1
- ReDim Preserve arr(1 To m)
- ReDim Preserve brr(1 To m)
- Set Wb = Workbooks.Open(myPath & myFile)
- arr(m) = Wb.Name
- ReDim crr(1 To Wb.Sheets.Count)
-
- For Each sh In Wb.Sheets
- i = i + 1
- crr(i) = sh.Name
- x = x + 1
- Next
- brr(m) = crr: Erase crr: i = 0
- Workbooks(myFile).Close False
- End If
- myFile = Dir
- Loop
- Application.ScreenUpdating = True
- TreeView1.ImageList = ImageList1
- ReDim bnode(1 To UBound(arr))
- ReDim snode(1 To x): x = 0
- For i = 1 To UBound(arr)
- key = "wb" & arr(i)
- Set bnode(i) = TreeView1.Nodes.Add(, , key, "工作簿：" & arr(i), 1)
- For j = 1 To UBound(brr(i))
- x = x + 1
- Set snode(x) = TreeView1.Nodes.Add(bnode(i).Index, tvwChild, , "工作表：" & brr(i)(j), 2)
- Next
- Next
- End Sub
- Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
- Dim myPath As String, myFile As String, Wb As Workbook, sh As Worksheet, dsh As Worksheet, nm As String, h%, l%, cs As Worksheet
- myPath = ThisWorkbook.Path & "\"
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- If InStr(Node.Text, "工作表") > 0 Then
- Set dsh = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
- myFile = Split(Node.Parent.Text, "：")(1)
- Set Wb = Workbooks.Open(myPath & myFile)
- nm = Split(Node.Text, "：")(1)
- Set sh = Wb.Worksheets(nm)
- h = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
- l = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
- sh.Range(sh.[a1], sh.Cells(h, l)).Copy dsh.[a1]
- On Error GoTo line1
- Set cs = ThisWorkbook.Worksheets(Wb.Name & "工作薄中表" & sh.Name)
- If Not cs Is Nothing Then cs.Delete
- line1:
- dsh.Name = Wb.Name & "工作薄中表" & sh.Name
- Workbooks(myFile).Close False
- Worksheets(1).Select
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End If
- End Sub
 树形目录和导入表.rar
|