遍历工作簿多条件查找数据

渭水之洲 · 发表于 2023-4-9 14:23

求助：

如何通过VBA宏来遍历工作簿中所有表，通过月份、姓名、考核项匹配查找出当月所得分值，然后汇总到第一张总表中！
如图所示

提前感谢大佬协助

蓝桥玄霜 · 发表于 2023-4-9 15:29

把分表“ 陈列部”的名字改为“陈列部”
抄入代码，执行即可。

渭水之洲 · 发表于 2023-4-9 15:41

蓝桥玄霜发表于 2023-4-9 15:29
把分表“ 陈列部”的名字改为“陈列部”
抄入代码，执行即可。

大佬方便把代码发出来么？这个图片手输入要点时间

Yalishanda30 · 发表于 2023-4-9 15:57

渭水之洲发表于 2023-4-9 15:41
大佬方便把代码发出来么？这个图片手输入要点时间

希望你自己借此机会练习练习，没想到你要喂到嘴里

渭水之洲 · 发表于 2023-4-9 16:17

Yalishanda30 发表于 2023-4-9 15:57
希望你自己借此机会练习练习，没想到你要喂到嘴里

主要是我着急用

Yalishanda30 · 发表于 2023-4-9 16:41

渭水之洲发表于 2023-4-9 16:17
主要是我着急用

10分钟抄代码的时间总有的

海好呀 · 发表于 2023-4-9 16:43

过来练练手，附件仅供参考，操作前请备份

还有你的源数据表头有重复的及有些考核项总表里没有，最好规范下，代码只写下3月的

盼哥 · 发表于 2023-4-9 18:20

Option Explicit
'专业VBA开发，生产优质代码！
Sub 汇总()
Dim tmpBook As Workbook
Set tmpBook = Workbooks.Add
Dim i&
Dim endrow&, r&
r = 1
With ThisWorkbook
For i = 2 To .Sheets.Count
With .Sheets(i)
endrow = .Cells(Rows.Count, 4).End(xlUp).Row
.UsedRange.Copy tmpBook.ActiveSheet.Cells(r, 1)
r = r + endrow
End With
Next
End With
Dim tmpRange As Range, 月列&
With ThisWorkbook
On Error Resume Next
Set tmpRange = ThisWorkbook.Sheets(2).Rows(1).Find(.Sheets("总").[D3].Value)
Set tmpRange = ThisWorkbook.Sheets(3).Rows(1).Find(.Sheets("总").[D3].Value)
On Error GoTo 0
If tmpRange Is Nothing Then
MsgBox "未找到指定月所在列"
Exit Sub
End If
月列 = tmpRange.Column
End With
Dim arr
With tmpBook
Dim cell As Range
Dim mergedCellRange As Range
For Each cell In .ActiveSheet.UsedRange
If cell.MergeCells Then
Set mergedCellRange = cell.MergeArea
With mergedCellRange
'获取合并单元格的内容
Dim cellText As String
cellText = cell.Value
'取消合并单元格
mergedCellRange.UnMerge
cell.Value = cellText
'将单元格内容填充到所有拆分出的单元格中
For i = 1 To .Cells.Count
.Cells(i).Value = cellText
Next
End With
End If
Next
arr = .ActiveSheet.UsedRange
.Close False
End With
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
d(arr(i, 2) & "_" & arr(i, 4)) = arr(i, 月列)
Next
Dim j&, endCol&
With ThisWorkbook.Sheets("总")
Call mkTitleDic(.UsedRange.Rows(2), d)
endCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
endrow = .Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To endrow
For j = 5 To endCol
.Cells(i, j) = d(.Cells(i, "C").Value & "_" & .Cells(2, j).Value)
Next
Next
End With
MsgBox "完成！"
End Sub
Sub mkTitleDic(sRange As Range, d)
'制作列号字典
'call mkTitleDic(范围，字典)
Dim eachCell
For Each eachCell In sRange.Cells
d(eachCell.Value) = eachCell.Column
Next
End Sub

复制代码

支持列名增加，改名，换位置。应该是比较完善的一个版本。

渭水之洲 · 发表于 2023-4-10 07:47

盼哥发表于 2023-4-9 18:20
支持列名增加，改名，换位置。应该是比较完善的一个版本。

感谢大佬，非常感谢

zyhui1961 · 发表于 2023-4-10 10:49

盼哥发表于 2023-4-9 18:20
支持列名增加，改名，换位置。应该是比较完善的一个版本。

老师您好！
下面的代码是将D6:至“终止”的上一行数据复制后粘贴数值到C6
请问我想将P6:至“终止”的上一行数据复制后粘贴数值到E6 ,怎么修改代码？谢谢！！！
Sub ykcbf()
Dim arr, brr, d
With Sheet1
      .Columns(3) = ""
      r = .Columns(4).Find("终止").Row
      .Range("d6:d" & r - 1).Copy
      .[c6].PasteSpecial Paste:=xlPasteValues
      Application.CutCopyMode = False
End With
End Sub

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

[求助] 遍历工作簿多条件查找数据

评分

评分

评分