根据关键字是否相同提取数据到新表

3190496160 · 发表于 2021-10-14 08:30

汇总表列字段必须跟分表完全一致，否则没法汇总，

hhxq001 · 发表于 2021-10-15 17:08

3190496160 发表于 2021-10-14 08:30
汇总表列字段必须跟分表完全一致，否则没法汇总，

关键字相同不能提取吗

hhxq001 · 发表于 2021-10-16 11:29

本帖最后由 hhxq001 于 2021-10-16 19:58 编辑

用InStr函数成功了。
Sub 取数() '导入数据
'1\弹框选择文件
Dim f
ChDrive Left(ThisWorkbook.FullName, 1) '指向当前盘
ChDir ThisWorkbook.Path '指向当前路径

f = Application.GetOpenFilename("Microsoft Office Excel 文件 (*.xls*),*.xls*", , "请选择要导入的数据表：")  '打开对话框，选择一个文件f
If f = False Then MsgBox "本次没有选择任何文件！点击确定退出": Exit Sub

  '2\打开要导入的源文
Dim sRow, dRow, dColumn As Long
Dim mySheet, FileName

Workbooks.Open f '打开源文件
Application.ScreenUpdating = False
FileName = Split(f, "\")(UBound(Split(f, "\"))) '获得选取文件的文件类型
Set mySheet = Workbooks(FileName).Sheets("sheet1") '获得表格名称

dRow = mySheet.[a65536].End(3).Row - 1 '获取源表的1列的最后一行非空行的行号，-1去掉合计行
dColumn = mySheet.[IV3].End(xlToLeft).Column '计算源表表头行占用的列数

      sRow = ThisWorkbook.Sheets(1).[b65536].End(3).Row + 1 '计算汇总表已有数据的行数，要提取的数据放在已有数据的后面

'3\开始取数
For a = 4 To dRow '源表的数据行从第4行开始
   For i = 1 To dColumn '原表的字段列从第1列开始

      If InStr(mySheet.Cells(3, i), "姓名") Then             '发现源表的3行i列字段包含姓名
         ThisWorkbook.Sheets(1).Cells(sRow, 2) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行2列
         sRow = sRow + 1
      End If
      If InStr(mySheet.Cells(3, i), "证") Then                '发现源表的3行i列字段包含应发
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 3) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行3列
      End If

      If InStr(mySheet.Cells(3, i), "应发") Then                '发现源表的3行i列字段包含应发
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 4) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行4列
      End If
      If InStr(mySheet.Cells(3, i), "实发") Then                '发现源表的3行i列字段包含应发
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 5) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行5列
      End If

      If InStr(mySheet.Cells(3, i), "公积金") Then             '发现源表的3行i列字段包含公积金
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 6) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行6列
      End If
      If InStr(mySheet.Cells(3, i), "养老") Then                '发现源表的3行i列字段包含应发
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 7) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行7列
      End If
      If InStr(mySheet.Cells(3, i), "养老保险") Then                '发现源表的3行i列字段包含应发
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 8) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行8列
      End If
      If InStr(mySheet.Cells(3, i), "职业") Then                '发现源表的3行i列字段包含公积金
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 9) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行9列
      End If
      If InStr(mySheet.Cells(3, i), "年金") Then                '发现源表的3行i列字段包含公积金
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 10) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行10列
      End If
      If InStr(mySheet.Cells(3, i), "大额") Then                '发现源表的3行i列字段包含公积金
         ThisWorkbook.Sheets(1).Cells(sRow - 1, 11) = Cells(a, i) '源表的a行i列数据就写入汇总表的srow行11列
      End If
   Next
Next

Workbooks(FileName).Close SaveChanges:=False ''关闭工作簿f并且不保存改动
Application.ScreenUpdating = True
Application.StatusBar = " *************************************************************************取数完成！"

End Sub

hhxq001 · 发表于 2021-10-22 17:57

hhxq001 发表于 2021-10-16 11:29
用InStr函数成功了。
Sub 取数() '导入数据
'1\弹框选择文件

改正后的表格

汇总问题.zip (51.48 KB, 下载次数: 23)

wmlj78 · 发表于 2021-10-30 10:35

老师好！这是当前路径下汇总，如果是指定文件汇总，代码该怎么修改？

wmlj78 · 发表于 2021-10-30 11:53

hhxq001 发表于 2021-10-22 17:57
改正后的表格

老师好！
改正后的表格

汇总问题.zip (51.48 KB, 下载次数: 5)

关于这个，能不能修改成动态的，比如汇总表标题行有什么字段，就提取什么字段？

hhxq001 · 发表于 2021-11-12 15:03

wmlj78 发表于 2021-10-30 11:53
老师好！
改正后的表格

这个需要原表和汇总表的字段一致才行。修改了一下，可以设置原表的哪个字段提取本表的哪列，你试一试

选择汇总.zip (32.99 KB, 下载次数: 30)

wmlj78 · 发表于 2021-11-21 13:58

hhxq001 发表于 2021-11-12 15:03
这个需要原表和汇总表的字段一致才行。修改了一下，可以设置原表的哪个字段提取本表的哪列，你试一试

谢谢您！我试试。

blackttea1 · 发表于 2021-11-21 17:06

学习啦，谢谢

wmlj78 · 发表于 2022-2-1 21:29

hhxq001 发表于 2021-11-12 15:03
这个需要原表和汇总表的字段一致才行。修改了一下，可以设置原表的哪个字段提取本表的哪列，你试一试

谢谢老师！好久没上了，才看到回复，谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 根据关键字是否相同提取数据到新表

最新热点 /1