【求助】大佬们，VBA如何循环遍历指定目录下的Excel文件并拼接字符串

蓝桥玄霜

请仔细核对抄写的代码，初学者常常会抄错的。

qxr130628

蓝桥玄霜 发表于 2017-9-20 10:22
请仔细核对抄写的代码，初学者常常会抄错的。

额 老师，抄写确实没有错误，我现在用的是2013版本的Excel 要循环遍历的文件是2003版本的并且每个表都是有个模板都有多个sheet页的呢。。。
我若是遍历2016版本的文件都没问题  就2003版本的不行总是提示数组越界

蓝桥玄霜

上面的Call searfile(fp, ".xlsx") 改为
Call searfile(fp, ".xls")
下面一个改为：
Sub searfile(fp As String, fkey As String)
Dim Arr1() As String, i1 As Integer, i2 As Integer, fm
If Right(fp, 1) <> "\" Then fp = fp & "\"
If Len(fkey) < 1 Then fkey = ".xls" '文件类型省略则仅搜索.xls文件
fm = Dir(fp, vbDirectory)
Do While fm <> ""
    If fm <> "." And fm <> ".." Then
        If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
            i1 = i1 + 1
            ReDim Preserve Arr1(1 To i1)
            Arr1(i1) = fp & fm
        End If
        If Right(fm, Len(fkey)) = fkey Then
            r = r + 1
            ReDim Preserve Brr(1 To 2, 1 To r)
            Brr(1, r) = fp
            Brr(2, r) = fm
        End If
    End If
    fm = Dir
Loop
For i2 = 1 To i1
  Call searfile(Arr1(i2), fkey)
Next
End Sub

qxr130628

蓝桥玄霜 发表于 2017-9-21 10:27
上面的Call searfile(fp, ".xlsx") 改为
Call searfile(fp, ".xls")
下面一个改为：

额 老师，可不可以同时遍历两种类型的文件呢？

蓝桥玄霜

改为：
Call searfile(fp, ".xls?")

qxr130628

蓝桥玄霜 发表于 2017-9-22 13:29
改为：
Call searfile(fp, ".xls?")

额，不行啊老师，改完了For i = 2 To UBound(Brr, 2) 数组下标越界了 呢，若是 xlsx与xls文件都有的的话仅读取xls的文件呢

蓝桥玄霜

1. Sub searfile(fp As String, fkey As String)
   
2. Dim Arr1() As String, i1 As Integer, i2 As Integer, fm
   
3. If Right(fp, 1) <> "" Then fp = fp & ""
   
4. If Len(fkey) < 1 Then fkey = ".xls" '文件类型省略则仅搜索.xls文件
   
5. fm = Dir(fp, vbDirectory)
   
6. Do While fm <> ""
   
7.     If fm <> "." And fm <> ".." Then
   
8.         If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
   
9.             i1 = i1 + 1
   
10.             ReDim Preserve Arr1(1 To i1)
    
11.             Arr1(i1) = fp & fm
    
12.         End If
    
13.         If InStr(Split(fm, ".")(1), "xls") Then
    
14.             r = r + 1
    
15.             ReDim Preserve Brr(1 To 2, 1 To r)
    
16.             Brr(1, r) = fp
    
17.             Brr(2, r) = fm
    
18.         End If
    
19.     End If
    
20.     fm = Dir
    
21. Loop
    
22. For i2 = 1 To i1
    
23.     Call searfile(Arr1(i2), fkey)
    
24. Next
    
25. End Sub
    

复制代码

qxr130628

蓝桥玄霜 发表于 2017-9-26 10:23

老师，改完代码之后 If InStr(Split(fm, ".")(1), "xls") Then  这句话 报数组下标越界了额。。。

蓝桥玄霜

建议上传Excel表格附件来测试代码。

qxr130628

蓝桥玄霜 发表于 2017-9-27 10:51
建议上传Excel表格附件来测试代码。

是这样的 我只想遍历A目录下的文件呢，并生成个新的Excel 保存在代码目录下