汇总表格增加手动选择exce表格功能l

wewes

汇总表格增加手动选择excel表格，Excel可能在其他盘符里 我运行程序之后选择就可以了。感谢

ykcbf1100

原代码我写的，改一下吧。

如果选择当前文件夹，直接按确定即可。

ykcbf1100

改成文件夹自选

1. Sub ykcbf()              '//2024.8.14  文件夹自选
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         .Title = "请选择文件夹"
   
7.         .InitialFileName = ThisWorkbook.Path & ""
   
8.         If .Show = -1 Then
   
9.             p = .SelectedItems(1) & ""
   
10.         End If
    
11.     End With
    
12.     ReDim brr(1 To 1000, 1 To 200)
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 n = n + 1
    
19.                 With wb.Sheets(1)
    
20.                     r = .Cells(Rows.Count, 1).End(3).Row
    
21.                     arr = .[a1].Resize(r, 2)
    
22.                     wb.Close False
    
23.                 End With
    
24.                 If n = 1 Then
    
25.                     m = m + 1
    
26.                     For i = 1 To UBound(arr)
    
27.                         brr(m, i) = arr(i, 1)
    
28.                     Next
    
29.                 End If
    
30.                 m = m + 1
    
31.                 For i = 1 To UBound(arr)
    
32.                     brr(m, i) = arr(i, 2)
    
33.                 Next
    
34.             End If
    
35.         End If
    
36.     Next f
    
37.     With sh
    
38.         .UsedRange.ClearContents
    
39.         .[a1].Resize(m, r) = brr
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

风过天涯

我也试试，这个是选择路径下的文件去汇总