多个工作薄多个表信息按某列信息合并到一张工作表中VBA

ykcbf1100

可爱小喵喵 发表于 2023-4-25 00:06
感谢！！！
这个我想到了在这里加下工作薄表名中的关键字
f = Dir(p & "工作薄关键字*.xls*")

可以的。。。

ykcbf1100

可爱小喵喵 发表于 2023-4-24 16:46
一下选择多个工作薄

动态选择工作簿，可以多选

ykcbf1100

代码如下：

1. Sub ykcbf()         '//2023.4.25
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr(1 To 10000, 1 To 1), crr(1 To 10000, 1 To 1), p, f, l
   
5.     b = [{"修改","回退"}]
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set sh = Sheets("脚本")
   
8.     With Application.FileDialog(msoFileDialogFilePicker)
   
9.         .Title = "请选择文件夹"
   
10.         .InitialFileName = ThisWorkbook.Path & ""
    
11.         .AllowMultiSelect = True
    
12.         .Filters.Clear
    
13.         .Filters.Add "Excel Files", "*.xls?"
    
14.         .Filters.Add "All Files", "*.*"
    
15.         .Show
    
16.         For l = 1 To .SelectedItems.Count
    
17.             f = .SelectedItems(l)
    
18.             Set wb = Workbooks.Open(f, 0)
    
19.             For Each sht In wb.Sheets
    
20.                 If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
    
21.                     With sht
    
22.                         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
23.                         c = .Cells(3, 255).End(xlToLeft).Column
    
24.                         arr = .[a1].Resize(r, c)
    
25.                     End With
    
26.                     For j = 2 To UBound(arr, 2)
    
27.                         If InStr(arr(3, j), b(1)) Then
    
28.                             For i = 4 To UBound(arr)
    
29.                                 If arr(i, j) <> Empty Then
    
30.                                     m = m + 1
    
31.                                     brr(m, 1) = arr(i, j)
    
32.                                 End If
    
33.                             Next
    
34.                         End If
    
35.                         If InStr(arr(3, j), b(2)) Then
    
36.                             For i = 4 To UBound(arr)
    
37.                                 If arr(i, j) <> Empty Then
    
38.                                     n = n + 1
    
39.                                     crr(n, 1) = arr(i, j)
    
40.                                 End If
    
41.                             Next
    
42.                         End If
    
43.                     Next
    
44.                 End If
    
45.             Next
    
46.             wb.Close False
    
47.         Next
    
48.     End With
    
49.     With sh
    
50.         .[h1].CurrentRegion.Offset(1).ClearContents
    
51.         .[h2].Resize(m, 1) = brr
    
52.         .[i2].Resize(n, 1) = brr
    
53.     End With
    
54.     Application.ScreenUpdating = True
    
55. End Sub
    

复制代码