提取包含标题行对应列数据

聆听我心

shiruiqiang 发表于 2024-12-5 16:17
每张表的标题统一的吗？这样可以，否则有点头疼

对方发的每张表的标题行不固定，但基本上都有关键字，我只提取这些包含关键字标题行列的数据，没有的就不提取。

ykcbf1100

聆听我心 发表于 2024-12-5 15:47
大师，我要提取的标题内容包含在被提取表标题内容里就可以，如被提取的标题可能是“身份证号码”，要提取 ...

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.12.5
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set sh = ThisWorkbook.Sheets("明细")
   
6.     arr = sh.UsedRange
   
7.     c = sh.UsedRange.Columns.Count
   
8.     ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
9.     For j = 2 To UBound(arr, 2)
   
10.         s = arr(1, j)
    
11.         d(s) = j
    
12.     Next
    
13.     f = p & "服刑人员表(8).xlsx"
    
14.     Set wb = Workbooks.Open(f, 0)
    
15.     With wb.Sheets(1)
    
16.         r = .Cells(Rows.Count, 1).End(3).Row
    
17.         c = .UsedRange.Columns.Count
    
18.         arr = .[a1].Resize(r, c)
    
19.     End With
    
20.     wb.Close 0
    
21.     For i = 2 To UBound(arr)
    
22.         m = m + 1
    
23.         brr(m, 1) = m
    
24.         For j = 1 To UBound(arr, 2)
    
25.             s = arr(1, j)
    
26.             For Each k In d.keys
    
27.                 If InStr(s, k) Then
    
28.                     brr(m, d(k)) = arr(i, j)
    
29.                     Exit For
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.     Next
    
34.     With sh
    
35.         .UsedRange.Offset(1).ClearContents
    
36.         .[a2].Resize(m, c) = brr
    
37.     End With
    
38.     Set d = Nothing
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    
42. 
    

复制代码

313667354

ykcbf1100 发表于 2024-12-5 16:27
参与一下。。。

草爷，感觉他好像不是提取固定的工作簿，是以（服刑）开头的所有工作簿都提取的意思。

liulang0808

liulang0808

程序文件通路经下有个服刑得文件夹，把需要汇总得文件都放到这个文件夹中，文件名带”服刑“字样得excel文件数据会被汇总得。
供参考

聆听我心

ykcbf1100 发表于 2024-12-5 16:27
参与一下。。。

感谢大师指点，通过大师的代码改写后实现了我的要求，大师辛苦了

聆听我心

liulang0808 发表于 2024-12-5 16:55
程序文件通路经下有个服刑得文件夹，把需要汇总得文件都放到这个文件夹中，文件名带”服刑“字样得excel文 ...

谢谢版主，想不到今天还得到版主指点，倍感荣幸，非常感谢

ykcbf1100

313667354 发表于 2024-12-5 16:48
草爷，感觉他好像不是提取固定的工作簿，是以（服刑）开头的所有工作簿都提取的意思。

嗯，应该是你说的意思。

改一下吧，适用有多个数据文件的情况。

ykcbf1100

改一下，适用多文件情况

1. Sub ykcbf()  '//2024.12.5
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("明细")
   
7.     arr = sh.UsedRange
   
8.     c = sh.UsedRange.Columns.Count
   
9.     ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
10.     For j = 2 To UBound(arr, 2)
    
11.         s = arr(1, j)
    
12.         d(s) = j
    
13.     Next
    
14.     For Each f In fso.GetFolder(p).Files
    
15.         If LCase$(f.Name) Like "*.xls*" Then
    
16.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 With wb.Sheets(1)
    
19.                     r = .Cells(Rows.Count, 1).End(3).Row
    
20.                     c = .UsedRange.Columns.Count
    
21.                     arr = .[a1].Resize(r, c)
    
22.                 End With
    
23.                 wb.Close 0
    
24.                 For i = 2 To UBound(arr)
    
25.                     m = m + 1
    
26.                     brr(m, 1) = m
    
27.                     For j = 1 To UBound(arr, 2)
    
28.                         s = arr(1, j)
    
29.                         For Each k In d.keys
    
30.                             If InStr(s, k) Then
    
31.                                 brr(m, d(k)) = arr(i, j)
    
32.                                 Exit For
    
33.                             End If
    
34.                         Next
    
35.                     Next
    
36.                 Next
    
37.             End If
    
38.         End If
    
39.     Next
    
40.     With sh
    
41.         .UsedRange.Offset(1).ClearContents
    
42.         .[a2].Resize(m, c) = brr
    
43.     End With
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码