跨表提取特定字段数据到新表格

cristter

小弟请求大神帮助下，

小弟有两个表格，一个是数据源，另外一个是汇总表。
希望通过VBA数据源里面特定的字段匹配到汇总表里（有图片说明）。
求求大神帮忙啦。。。。。。感激不尽。

PS：请别建议使用数据透视表或者函数解决，因为确实有不方便地方，而且实际数据源更大。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.28
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path
   
5.     Set sh = ThisWorkbook.Sheets("名单")
   
6.     arr = sh.UsedRange
   
7.     b = [{"姓名","身份证","电话号码","城市","区域","课程","级别"}]
   
8.     For j = 1 To UBound(arr, 2)
   
9.         s = arr(2, j)
   
10.         If s = "姓名" Then s = "申请人"
    
11.         d(s) = j
    
12.     Next
    
13.     c = UBound(arr, 2)
    
14.     With Application.FileDialog(msoFileDialogFilePicker)
    
15.         .InitialFileName = p
    
16.         .Title = "请选择对应Excel文件"
    
17.         .AllowMultiSelect = False
    
18.         .Filters.Clear
    
19.         .Filters.Add "Excel文件", "*.xls*"
    
20.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
21.     End With
    
22.     Set wb = Workbooks.Open(f, 0)
    
23.     With wb.Sheets("Sheet1")
    
24.         arr = .UsedRange
    
25.         wb.Close False
    
26.     End With
    
27.     ReDim brr(1 To UBound(arr), 1 To c)
    
28.     For i = 2 To UBound(arr)
    
29.         If arr(i, 3) <> Empty Then
    
30.             m = m + 1
    
31.             For j = 1 To UBound(arr, 2)
    
32.                 s = arr(1, j)
    
33.                 If d.exists(s) Then
    
34.                     brr(m, d(s)) = arr(i, j)
    
35.                 End If
    
36.             Next
    
37.         End If
    
38.     Next
    
39.     With sh
    
40.         .UsedRange.Offset(2).ClearContents
    
41.         .Columns(2).NumberFormatLocal = "@"
    
42.         With .[a3].Resize(m, c)
    
43.             .Value = brr
    
44.             .Borders.LineStyle = 1
    
45.             .HorizontalAlignment = xlCenter  '//列居中
    
46.             .VerticalAlignment = xlCenter
    
47.         End With
    
48.     End With
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    
53. 
    

复制代码

cnmlgb9998

我也用次函数。 把汇总表考到数据表的工作簿中，再操作。

fzxba

1. Sub test0()
   
2.   
   
3.   Dim strFile As String
   
4.   strFile = ThisWorkbook.Path & "\数据源.xlsx"
   
5.   If Dir(strFile) = "" Then Exit Sub
   
6.   
   
7.   Dim Conn As Object, SQL As String
   
8.   
   
9.   With Worksheets("名单")
   
10.     .Activate
    
11.     .UsedRange.Offset(2).ClearContents
    
12.   End With
    
13.   
    
14.   Set Conn = CreateObject("ADODB.Connection")
    
15.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & strFile
    
16.   
    
17.   SQL = "SELECT 申请人,身份证,电话号码,城市,区域,课程,级别 FROM [Sheet1$] WHERE 申请人 IS NOT NULL"
    
18.   Range("A3").CopyFromRecordset Conn.Execute(SQL)
    
19.   
    
20.   Conn.Close
    
21.   Set Conn = Nothing
    
22.   Beep
    
23. End Sub

复制代码

fzxba

怎么传不了附件？
测试.zip (26.78 KB, 下载次数: 16)

2024-3-28 17:34 上传

点击文件名下载附件

xlj310

我也参与一下，思路跟上面版主的差不多，可以说是雷同   我这个做的是通用的。供参考吧~

xlj310

我也参与一下，思路跟上面版主的差不多，可以说是雷同   我这个做的是通用的。供参考吧~

LIUZHU

目前是这个效果

LIUZHU

JSA代码，请参阅

1. function 提取(){
   
2.         Workbooks.Open(`${ThisWorkbook.Path}\\数据源.xlsx`);
   
3.         let arr=Range("a1").CurrentRegion.Value2;
   
4.         ActiveWorkbook.Close(false);
   
5.         let obj=arr[0].reduce((dic,x,i)=>(dic[x]=i,dic),{});
   
6.         let bt=Sheets.Item("名单").Range("a2").CurrentRegion.Value2[1];
   
7.         let res=arr.slice(1).reduce((res,x)=>{
   
8.                 let temp=bt.reduce((temp,y,i)=>(temp[i]=x[obj[y]],temp),[]);
   
9.                 temp[0]=x[obj.申请人];                //姓名
   
10.                 return (res.push(temp),res);
    
11.         },[]);
    
12.         Range("a3").Resize(res.length,res[0].length).Value2=res;
    
13. }

复制代码