[已解决]如何提取文件夹内子文件夹的所有资料 有图有代码

qinhuan66

如何修改红框圈内黄底色的这句代码提取数据库文件夹的资料换成提取数据库文件夹内子文件夹的所有资料
测试.rar (115.82 KB, 下载次数: 47)

2013-2-6 09:45 上传

点击文件名下载附件



代码如下：

Sub 提取数据()
   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   Application.DisplayAlerts = False

   myPath = ThisWorkbook.Path & "\数据库\"          '把文件路径定义给变量

   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
   Do While myFile <> ""                     '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件

         For i = 6 To 65536 Step 1
         If AK.Sheets(1).Cells(i, 1).Value <> "" Then

         Else
         Exit For
         End If
         Next

         aRow = i - 1
         tRow = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1
         If tRow < 5 Then tRow = 5


         arr = AK.Sheets(1).Range("a6:q" & aRow)
         ThisWorkbook.Sheets(1).Range("A" & tRow).Resize(UBound(arr), UBound(arr, 2)) = arr
         ThisWorkbook.Sheets(1).Range("R" & tRow).Resize(UBound(arr), 1) = AK.Sheets(1).Range("c2")

         Workbooks(myFile).Close False               '关闭源工作簿,并不作修改
      End If
      myFile = Dir                                   '找寻下一个*.xls文件
   Loop

   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
   MsgBox "汇总完成，请查看！", 64, "提示"
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-6 13:40

1. Sub 提取数据()
   
2.     Dim myPath$
   
3.     Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   
4.     Application.DisplayAlerts = False
   
5. 
   
6.     myPath = ThisWorkbook.Path & "\数据库"          '把文件路径定义给变量
   
7.     ListDirs myPath
   
8. 
   
9. 
   
10.     Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
    
11.     MsgBox "汇总完成，请查看！", 64, "提示"
    
12. End Sub
    
13. 
    
14. Sub 删除5至10000行数据()
    
15.     Rows("5:10000").Delete Shift:=xlUp
    
16. End Sub
    
17. 
    
18. 
    
19. Sub ListDirs(ByVal Path As String)
    
20. '文件名
    
21.     Dim filename$
    
22.     '文件夹数组
    
23.     Dim arrPath()
    
24.     '当前搜索的文件夹
    
25.     Dim sPath$
    
26.     '计数变量
    
27.     Dim i&, j&, k&
    
28.     Dim AK As Workbook, aRow%, tRow%
    
29.     i = 1: j = 1
    
30. 
    
31.     ReDim arrPath(1 To 1)
    
32.     arrPath(i) = Path & Application.PathSeparator
    
33.     'On Error Resume Next
    
34. 
    
35.     sPath = arrPath(j)
    
36.     'Debug.Print sPath
    
37.     Do While Len(sPath)
    
38.         Debug.Print "--------------------"
    
39.         Debug.Print sPath
    
40.         '搜索文件和文件夹（无属性设置的）
    
41.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
42.         Do While Len(filename)
    
43.             '跳过. 和 .. 文件夹
    
44.             If Not (filename = "." Or filename = "..") Then
    
45.                 '判断是否为文件夹
    
46.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
47.                     '避免读取错误
    
48.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
49.                     i = i + 1
    
50.                     '把搜索到的子文件夹放入数组中
    
51.                     ReDim Preserve arrPath(1 To i)
    
52.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
53.                 Else
    
54.                     '在在此处加入针对文件处理的代码
    
55. 
    
56. 
    
57. 
    
58.                     If filename <> ThisWorkbook.Name And UCase(filename) Like "*.XLS" Then
    
59.                         Debug.Print filename
    
60.                         Set AK = Workbooks.Open(sPath & filename)          '打开符合要求的文件
    
61. 
    
62.                         For k = 6 To 65536
    
63.                             If AK.Sheets(1).Cells(k, 1).Value = "" Then Exit For
    
64.                         Next
    
65.                         aRow = k - 1
    
66.                         tRow = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1
    
67.                         If tRow < 5 Then tRow = 5
    
68.                         arr = AK.Sheets(1).Range("a6:q" & aRow)
    
69.                         ThisWorkbook.Sheets(1).Range("A" & tRow).Resize(UBound(arr), UBound(arr, 2)) = arr
    
70.                         ThisWorkbook.Sheets(1).Range("R" & tRow).Resize(UBound(arr), 1) = AK.Sheets(1).Range("c2")
    
71.                         Workbooks(filename).Close False               '关闭源工作簿,并不作修改
    
72.                     End If
    
73.                 End If
    
74.             End If
    
75. End1If:
    
76.             filename = Dir
    
77.         Loop
    
78. 
    
79.         j = j + 1
    
80.         If j > i Then Exit Do
    
81.         sPath = arrPath(j)
    
82.     Loop
    
83. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

你参考下这个过程，加进去自己针对工作簿的处理代码就成了。

1. Sub ListDirs(ByVal Path As String)
   
2.     Dim filename$
   
3.     Dim arrPath()
   
4.     Dim sPath$
   
5.     Dim i&, j&
   
6. 
   
7.     i = 1: j = 1
   
8. 
   
9.     ReDim arrPath(1 To 1)
   
10.     arrPath(i) = Path & Application.PathSeparator
    
11.     'On Error Resume Next
    
12. 
    
13.     sPath = arrPath(j)
    
14.     Debug.Print sPath
    
15.     Do While Len(sPath)
    
16.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
17.         Do While Len(filename)
    
18. 
    
19.             If Not (filename = "." Or filename = "..") Then
    
20.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
21.                     '避免读取错误
    
22.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
23.                     i = i + 1
    
24.                     ReDim Preserve arrPath(1 To i)
    
25.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
26.                 Else
    
27.                     '文件处理代码
    
28.                 End If
    
29.             End If
    
30. End1If:
    
31.             filename = Dir
    
32.         Loop
    
33. 
    
34.         j = j + 1
    
35.         If j > i Then Exit Do
    
36.         sPath = arrPath(j)
    
37.     Loop
    
38. End Sub

复制代码

qinhuan66

hwc2ycy 发表于 2013-2-6 09:59
你参考下这个过程，加进去自己针对工作簿的处理代码就成了。

老师能帮处理一下吗我才刚学习VBA对我来说有点难度  谢谢

hwc2ycy

1. Sub ListDirs(ByVal Path As String)
   
2.     '文件名
   
3.     Dim filename$
   
4.     '文件夹数组
   
5.     Dim arrPath()
   
6.     '当前搜索的文件夹
   
7.     Dim sPath$
   
8.     '计数变量
   
9.     Dim i&, j&
   
10. 
    
11.     i = 1: j = 1
    
12. 
    
13.     ReDim arrPath(1 To 1)
    
14.     arrPath(i) = Path & Application.PathSeparator
    
15.     'On Error Resume Next
    
16. 
    
17.     sPath = arrPath(j)
    
18.     'Debug.Print sPath
    
19.     Do While Len(sPath)
    
20.         '搜索文件和文件夹（无属性设置的）
    
21.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
22.         Do While Len(filename)
    
23.             '跳过. 和 .. 文件夹
    
24.             If Not (filename = "." Or filename = "..") Then
    
25.                 '判断是否为文件夹
    
26.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
27.                     '避免读取错误
    
28.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
29.                     i = i + 1
    
30.                     '把搜索到的子文件夹放入数组中
    
31.                     ReDim Preserve arrPath(1 To i)
    
32.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
33.                 Else
    
34.                     '在在此处加入针对文件处理的代码
    
35.                     '
    
36.                     '
    
37.                     '
    
38.                 End If
    
39.             End If
    
40. End1If:
    
41.             filename = Dir
    
42.         Loop
    
43. 
    
44.         j = j + 1
    
45.         If j > i Then Exit Do
    
46.         sPath = arrPath(j)
    
47.     Loop
    
48. End Sub

复制代码

qinhuan66

hwc2ycy 发表于 2013-2-6 10:02

好的老师那我先试一下，不懂再请教你。谢谢了老师

qinhuan66

hwc2ycy 发表于 2013-2-6 10:02

老师能按照我的附件帮修改一下吗？谢谢

hwc2ycy

你的整合进来了。
你直接调用 call listdirs 你的数据路径

1. Sub ListDirs(ByVal Path As String)
   
2. '文件名
   
3.     Dim filename$
   
4.     '文件夹数组
   
5.     Dim arrPath()
   
6.     '当前搜索的文件夹
   
7.     Dim sPath$
   
8.     '计数变量
   
9.     Dim i&, j&
   
10. 
    
11.     i = 1: j = 1
    
12. 
    
13.     ReDim arrPath(1 To 1)
    
14.     arrPath(i) = Path & Application.PathSeparator
    
15.     'On Error Resume Next
    
16. 
    
17.     sPath = arrPath(j)
    
18.     'Debug.Print sPath
    
19.     Do While Len(sPath)
    
20.         '搜索文件和文件夹（无属性设置的）
    
21.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
22.         Do While Len(filename)
    
23.             '跳过. 和 .. 文件夹
    
24.             If Not (filename = "." Or filename = "..") Then
    
25.                 '判断是否为文件夹
    
26.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
27.                     '避免读取错误
    
28.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
29.                     i = i + 1
    
30.                     '把搜索到的子文件夹放入数组中
    
31.                     ReDim Preserve arrPath(1 To i)
    
32.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
33.                 Else
    
34.                     '在在此处加入针对文件处理的代码
    
35.                     '
    
36.                     '
    
37.                     '
    
38.                     If filename <> ThisWorkbook.Name And upper(filename) Like "*.XLS" Then
    
39.                         Set AK = Workbooks.Open(sPath & filename)          '打开符合要求的文件
    
40. 
    
41.                         For i = 6 To 65536 Step 1
    
42.                             If AK.Sheets(1).Cells(i, 1).Value <> "" Then
    
43.                             Else
    
44.                                 Exit For
    
45.                             End If
    
46.                         Next
    
47.                         aRow = i - 1
    
48.                         tRow = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1
    
49.                         If tRow < 5 Then tRow = 5
    
50.                         arr = AK.Sheets(1).Range("a6:q" & aRow)
    
51.                         ThisWorkbook.Sheets(1).Range("A" & tRow).Resize(UBound(arr), UBound(arr, 2)) = arr
    
52.                         ThisWorkbook.Sheets(1).Range("R" & tRow).Resize(UBound(arr), 1) = AK.Sheets(1).Range("c2")
    
53.                         Workbooks(filename).Close False               '关闭源工作簿,并不作修改
    
54. 
    
55.                     End If
    
56.                 End If
    
57. End1If:
    
58.                 filename = Dir
    
59.             Loop
    
60. 
    
61.             j = j + 1
    
62.             If j > i Then Exit Do
    
63.             sPath = arrPath(j)
    
64.         Loop
    
65. End Sub

复制代码

hwc2ycy

1.                         For i = 6 To 65536 Step 1
   
2.                             If AK.Sheets(1).Cells(i, 1).Value <> "" Then
   
3.                             Else
   
4.                                 Exit For
   
5.                             End If
   
6.                         Next

复制代码

你这里可以直接改成

1.                         For i = 6 To 65536 Step 1
   
2.                             If AK.Sheets(1).Cells(i, 1).Value = "" Then Exit For
   
3.                         Next

复制代码

qinhuan66

hwc2ycy 发表于 2013-2-6 10:11
你这里可以直接改成

老师我试了好多遍都不行呢。水平有限没办法。

hwc2ycy

你没用对方法，你要调用这个过程，直接用是没效的。