求：根据表格指定条件批量提取单元格数据

倾听冷暖丿

各位大神，老师，能否帮忙改改代码，根据提取条件内容，来提取对应数据，更改条件直接

E风卍行H

里面藏了啥大宝贝，还加密了……

倾听冷暖丿

下载这个附件

倾听冷暖丿

E风卍行H 发表于 2022-11-18 10:59
里面藏了啥大宝贝，还加密了……

忘记取消了   下载这个吧

E风卍行H

1. Sub find()
   
2.     Rem 文件路径
   
3.     Dim pth As String
   
4.     pth = ThisWorkbook.Path & ""
   
5.    
   
6.     Rem 当前文件名
   
7.     Dim myname As String
   
8.     myname = ThisWorkbook.Name
   
9.    
   
10.     Rem 获取文件名
    
11.     Dim arr(), a As Integer, flname As String
    
12.     flname = Dir(pth)   '获取文件名
    
13.     Do While flname <> ""
    
14.         Rem 不是当前文件，就是需要处理的文件
    
15.         If flname <> myname Then
    
16.             a = a + 1 '文件数量加1
    
17.             ReDim Preserve arr(1 To a)  '重定义数组大小，并保留数据
    
18.             arr(a) = flname '文件名存入数组
    
19.         End If
    
20.         flname = Dir    '继续获取文件名
    
21.     Loop
    
22.    
    
23.     Rem 没有文件则退出
    
24.     If a = 0 Then
    
25.         MsgBox "未发现文件！"
    
26.         Exit Sub
    
27.     End If
    
28.    
    
29.     Rem 条件数组
    
30.     Dim brr
    
31.     brr = Range("G2:G5").Value
    
32.    
    
33.     Rem 结果数组
    
34.     Dim crr(), i As Long
    
35.     ReDim crr(1 To a, 1 To 4)
    
36.     For i = 1 To a
    
37.         crr(i, 1) = arr(i)   '文件名存入数组
    
38.     Next
    
39.    
    
40.     Application.ScreenUpdating = False  '禁用屏幕刷新
    
41.    
    
42.     Rem 要提取的数据存入数组
    
43.     Dim sht As Worksheet, j As Integer
    
44.     For i = 1 To a
    
45.         Workbooks.Open pth & arr(i), False  '打开文件且不更新
    
46.         With ActiveWorkbook
    
47.             On Error Resume Next    '出现错误则继续
    
48.             
    
49.             Rem 变量赋值，判断工作表是否存在
    
50.             Set sht = .Sheets(brr(1, 1))
    
51.             
    
52.             Rem 文件存在(没有错误)则处理，不存在则下一个
    
53.             If Err.Number = 0 Then
    
54.                 With sht
    
55.                     For j = 2 To 4
    
56.                         crr(i, j) = .Range(brr(j, 1)).Value '提取数据
    
57.                     Next j
    
58.                 End With
    
59.             Else
    
60.                 Err.Clear   '清除错误，继续处理下一个
    
61.             End If
    
62.             
    
63.             On Error GoTo 0 '恢复错误处理（出现其他错误时提示）
    
64.             
    
65.             .Close False    '关闭文件且不保存
    
66.         End With
    
67.     Next i
    
68.    
    
69.     Call scsj   '调用过程，清除原有数据
    
70.     Range("A3").Resize(a, 4).Value = crr '输入提取结果
    
71. 
    
72.     Application.ScreenUpdating = True   '恢复屏幕刷新
    
73.    
    
74.     MsgBox "处理完成！"
    
75. End Sub

复制代码

E风卍行H

附件供参考