[已解决]vba遍历文件夹选取数据

yuan1987

hwc2ycy 发表于 2013-6-28 08:34
没有这个工作表，那就肯定要报错了。

有这个工作表啊，可以下载一下附件啊

hwc2ycy

1. Sub 汇总()
   
2.     Application.ScreenUpdating = False
   
3.     Dim lj As String, m, n
   
4.     Dim dirname As String
   
5.     Dim nm As String
   
6.     Dim wb As Workbook
   
7.     Dim i As Integer
   
8. 
   
9.     On Error Resume Next
   
10. 
    
11.     With Application
    
12.         .ScreenUpdating = False
    
13.         .DisplayAlerts = False
    
14.         .EnableEvents = False
    
15.         .Calculation = xlCalculationManual
    
16.     End With
    
17. 
    
18.     lj = ThisWorkbook.Path
    
19.     nm = ThisWorkbook.Name
    
20.     dirname = Dir(lj & "\*.xlsx")
    
21.     Cells.Clear
    
22.     Do While dirname <> ""
    
23.         If dirname <> nm Then
    
24.             Set wb = Workbooks.Open(Filename:=lj & "" & dirname, UpdateLinks:=False, ReadOnly:=True)
    
25.             If Not wb Is Nothing Then
    
26.                 With wb
    
27.                     If Len(.Sheets("开始").Name) = 0 Then
    
28.                     Else
    
29.                         i = .Sheets("开始").Range("A65536").End(xlUp).Row
    
30.                         ThisWorkbook.Sheets("统计表").Cells(m, 1) = .Sheets("开始").Cells(2, 1).Value
    
31.                         ThisWorkbook.Sheets("统计表").Cells(n, 2) = .Sheets("开始").Cells(2, 1).Value
    
32.                     End If
    
33.                     .Close False
    
34.                 End With
    
35.                 Set wb = Nothing
    
36.             End If
    
37.         End If
    
38.         dirname = Dir
    
39.     Loop
    
40.     With Application
    
41.         .ScreenUpdating = True
    
42.         .DisplayAlerts = True
    
43.         .EnableEvents = True
    
44.         .Calculation = xlCalculationAutomatic
    
45.     End With
    
46.     MsgBox "OK"
    
47. End Sub
    

复制代码

hwc2ycy

你的代码不能实现遍历子文件夹。

ybchxj2010

提供利用FSO+递归的方案供参考！

1. Dim ARR$(1 To 10000, 1 To 2), i&
   
2. Dim Fso As Object
   
3. 
   
4. Sub GetPathdata()
   
5.   On Error Resume Next
   
6.   Application.ScreenUpdating = False
   
7.   
   
8.   Sheets("统计表").Select
   
9.   Set Fso = VBA.CreateObject("Scripting.FileSystemObject")
   
10.     Outputfiles ThisWorkbook.Path
    
11.   Range("A2").Resize(i, 2) = ARR
    
12.   
    
13.   Set Fso = Nothing
    
14.   Erase ARR
    
15.   i = 0
    
16.   
    
17.   Application.ScreenUpdating = True
    
18. End Sub
    
19. 
    
20. Sub Outputfiles(Strpath$)
    
21.   Dim fd, f, sfd
    
22.   Dim N&
    
23.   Dim Wb As Workbook
    
24.   
    
25.   Set fd = Fso.GetFolder(Strpath)
    
26.   
    
27.   For Each f In fd.Files
    
28.       If f.Name Like "*基本情况表.xls*" Then
    
29.          Set Wb = Workbooks.Open(Filename:=f.Path)
    
30.          i = i + 1
    
31.          With Wb.Sheets(1)
    
32.            ARR(i, 1) = .Range("a2")
    
33.            ARR(i, 2) = .Range("b2")
    
34.          End With
    
35.         Wb.Close False
    
36.       End If
    
37.   Next
    
38.   
    
39.   N = fd.SubFolders.Count
    
40.   If N > 0 Then
    
41.     For Each sfd In fd.SubFolders
    
42.       Outputfiles sfd.Path
    
43.     Next
    
44.   End If
    
45. 
    
46. End Sub

复制代码

yuan1987

If Len(.Sheets("开始").Name) = 0 Then,运行到这一步下标又越界了，但是我文件夹里边是有这个名称的工作表的

yuan1987

hwc2ycy 发表于 2013-6-28 09:03
你的代码不能实现遍历子文件夹。

那个代码实现不了结果啊