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

hwc2ycy

还要加上参数。

qinhuan66

hwc2ycy 发表于 2013-2-6 11:23
你没用对方法，你要调用这个过程，直接用是没效的。

老师在吗？我试了一下还是不知道咋调用。能再指导一下吗？

hwc2ycy

等下帮你弄，我洗个澡着。

hwc2ycy

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

养老保险待遇发放系统.rar (46.72 KB, 下载次数: 6)

2013-2-6 13:42 上传

点击文件名下载附件
有两个地方没注意了。upper弄错了。
然后你的统计代码里也有个变量i，跟我遍历目录的代码里的变量i冲突，导致下标越界。

qinhuan66

hwc2ycy 发表于 2013-2-6 13:43
有两个地方没注意了。upper弄错了。
然后你的统计代码里也有个变量i，跟我遍历目录的代码里的变量i冲突， ...

谢谢了朋友！你真是帮了我一个大忙。真的感激不尽呀。对了有空的话帮忙看最后一个问题，也是像上面那个提取汇总的路径一模一样。
代码如下：
Sub 生成数据()
Dim wj As String, fs As Object, arr, Rng As Range, Y!, N1&, N2&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Range("a5:s500").ClearContents
wj = Dir(ThisWorkbook.Path & "\数据库\")
s = 2
Do While wj <> ""
    If s = 2 Then
        ReDim arr(1 To 23, 1 To 1)
    Else
        ReDim Preserve arr(1 To 23, 1 To UBound(arr, 2) + 1)
    End If
    s = s + 1
    Set fs = GetObject(ThisWorkbook.Path & "\数据库\" & wj)
    arr(1, s - 2) = s - 2
    arr(2, s - 2) = Mid(wj, 4, IIf(InStr(wj, "区") > 0, InStr(wj, "区") - 3, InStr(wj, "村") - 3))
    arr(3, s - 2) = fs.Sheets(1).[P2]
    arr(4, s - 2) = "=SUM(RC[1]+RC[2])"
    arr(5, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放")
    arr(6, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发")
    arr(7, s - 2) = "=SUM(RC[1]+RC[4])"
    arr(8, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("G6:G10000"))
    arr(9, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("H6:H10000"))
    arr(10, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("I6:I10000"))
    arr(11, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("J6:J10000"))
    arr(12, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("K6:K10000"))
    arr(13, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("L6:L10000"))
    arr(16, s - 2) = ""
    arr(17, s - 2) = ""
    arr(18, s - 2) = ""
    arr(19, s - 2) = ""
    arr(20, s - 2) = ""
    arr(21, s - 2) = ""
    arr(22, s - 2) = ""
    arr(23, s - 2) = ""
    With fs.Sheets(1)
        N1 = 0
        N2 = 0
        For Each Rng In .Range("d6:d" & .Cells(.Rows.Count, 4).End(3).Row)
            If Rng <> "" And (.Cells(Rng.Row, "Q").Value = "正常发放" Or .Cells(Rng.Row, "Q").Value = "死亡停发") Then
                Y = Val(IIf(Len(Rng.Text) = 18, Mid(Trim(Rng.Text), 7, 4), "19" & Mid(Trim(Rng.Text), 7, 2)))
                Select Case Y
                    Case Is <= 1949
                        N1 = N1 + 1
                    Case Is <= 1952
                        N2 = N2 + 1
                    Case Else

                End Select
            End If
        Next Rng
    End With
    arr(14, s - 2) = Val(arr(14, s - 2)) + N1
    arr(15, s - 2) = Val(arr(15, s - 2)) + N2
    fs.Close False
    wj = Dir
Loop
Cells(5, 1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub 删除数据()
Range("A5:w65536").ClearContents
End Sub

qinhuan66

hwc2ycy 发表于 2013-2-6 13:43
有两个地方没注意了。upper弄错了。
然后你的统计代码里也有个变量i，跟我遍历目录的代码里的变量i冲突， ...

我试做了上面这个老是跳出  LOOP没有DO 等等

hwc2ycy

这个代码是我用的遍历模板，没问题的。
你单步看看，直接跳出，肯定是没找到文件嘛。

qinhuan66

hwc2ycy 发表于 2013-2-6 16:04
这个代码是我用的遍历模板，没问题的。
你单步看看，直接跳出，肯定是没找到文件嘛。

老师帮帮手好吗，准备放假了，我想弄好过了年来得用。谢谢

hwc2ycy

1. Option Explicit
   
2. Dim arr
   
3. 
   
4. Sub 生成数据()
   
5.     Dim filename As String ', , Rng As Range,
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.EnableEvents = False
   
9.     Range("a5:s500").ClearContents
   
10. 
    
11.     ListDirs ThisWorkbook.Path & "\数据库"
    
12. 
    
13.     Cells(5, 1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
    
14.     Application.EnableEvents = True
    
15.     Application.DisplayAlerts = True
    
16.     Application.ScreenUpdating = True
    
17. End Sub
    
18. Sub 删除数据()
    
19.     Range("A5:w65536").ClearContents
    
20. End Sub
    
21. 
    
22. 
    
23. Sub ListDirs(ByVal Path As String)
    
24.     '文件名
    
25.     Dim filename$
    
26.     '文件夹数组
    
27.     Dim arrPath()
    
28.     '当前搜索的文件夹
    
29.     Dim sPath$
    
30.     '计数变量
    
31.     Dim i&, j&, k&, s&
    
32.     Dim N1&, N2&, Y!
    
33.     Dim fs As Workbook
    
34.     Dim Rng As Range
    
35.     i = 1: j = 1
    
36.     s = 2
    
37.     ReDim arrPath(1 To 1)
    
38.    
    
39.     arrPath(i) = Path & Application.PathSeparator
    
40.     'On Error Resume Next
    
41.     sPath = arrPath(j)
    
42.    
    
43.     Do While Len(sPath)
    
44.         'Debug.Print "--------------------"
    
45.         'Debug.Print sPath
    
46.         
    
47.         '搜索文件和文件夹（无属性设置的）
    
48.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
49.         Do While Len(filename)
    
50.             '跳过. 和 .. 文件夹
    
51.             If Not (filename = "." Or filename = "..") Then
    
52.                 '判断是否为文件夹
    
53.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
54.                     '避免读取错误
    
55.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
56.                     i = i + 1
    
57.                     '把搜索到的子文件夹放入数组中
    
58.                     ReDim Preserve arrPath(1 To i)
    
59.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
60.                 Else
    
61.                     If filename <> ThisWorkbook.Name And (Not LCase(filename) Like "*.xls") Then
    
62.                         '在在此处加入针对文件处理的代码
    
63.                         If s = 2 Then
    
64.                             ReDim arr(1 To 23, 1 To 1)
    
65.                         Else
    
66.                             ReDim Preserve arr(1 To 23, 1 To UBound(arr, 2) + 1)
    
67.                         End If
    
68.                         s = s + 1
    
69.                         Set fs = GetObject(sPath & filename)
    
70.                         arr(1, s - 2) = s - 2
    
71.                         arr(2, s - 2) = Mid(filename, 4, IIf(InStr(filename, "区") > 0, InStr(filename, "区") - 3, InStr(filename, "村") - 3))
    
72.                         arr(3, s - 2) = fs.Sheets(1).[P2]
    
73.                         arr(4, s - 2) = "=SUM(RC[1]+RC[2])"
    
74.                         arr(5, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放")
    
75.                         arr(6, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发")
    
76.                         arr(7, s - 2) = "=SUM(RC[1]+RC[4])"
    
77.                         arr(8, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("G6:G10000"))
    
78.                         arr(9, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("H6:H10000"))
    
79.                         arr(10, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "正常发放", fs.Sheets(1).Range("I6:I10000"))
    
80.                         arr(11, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("J6:J10000"))
    
81.                         arr(12, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("K6:K10000"))
    
82.                         arr(13, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("Q6:Q10000"), "死亡停发", fs.Sheets(1).Range("L6:L10000"))
    
83.                         arr(16, s - 2) = ""
    
84.                         arr(17, s - 2) = ""
    
85.                         arr(18, s - 2) = ""
    
86.                         arr(19, s - 2) = ""
    
87.                         arr(20, s - 2) = ""
    
88.                         arr(21, s - 2) = ""
    
89.                         arr(22, s - 2) = ""
    
90.                         arr(23, s - 2) = ""
    
91.                         With fs.Sheets(1)
    
92.                             N1 = 0
    
93.                             N2 = 0
    
94.                             For Each Rng In .Range("d6:d" & .Cells(.Rows.Count, 4).End(3).Row)
    
95.                                 If Rng <> "" And (.Cells(Rng.Row, "Q").Value = "正常发放" Or .Cells(Rng.Row, "Q").Value = "死亡停发") Then
    
96.                                     Y = Val(IIf(Len(Rng.Text) = 18, Mid(Trim(Rng.Text), 7, 4), "19" & Mid(Trim(Rng.Text), 7, 2)))
    
97.                                     Select Case Y
    
98.                                         Case Is <= 1949
    
99.                                             N1 = N1 + 1
    
100.                                         Case Is <= 1952
     
101.                                             N2 = N2 + 1
     
102.                                         Case Else
     
103. 
     
104.                                     End Select
     
105.                                 End If
     
106.                             Next Rng
     
107.                         End With
     
108.                         arr(14, s - 2) = Val(arr(14, s - 2)) + N1
     
109.                         arr(15, s - 2) = Val(arr(15, s - 2)) + N2
     
110.                         fs.Close False
     
111.                     End If
     
112.                 End If
     
113.             End If
     
114. End1If:
     
115.                 filename = Dir
     
116.             Loop
     
117. 
     
118.             j = j + 1
     
119.             If j > i Then Exit Do
     
120.             sPath = arrPath(j)
     
121.         Loop
     
122.     End Sub

复制代码