跨工作簿查询第一个工作表数据到汇总表，数组字典方法，谢谢！

hcy1185

在网上找的代码，是此工作表结果，我想得到颜色的值填到颜色对应列，请老师指导！谢谢！
字典条目数为序号，工号&姓名为关键字，文件夹下的工作簿第一个工作表的第6列条目对应值，

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
楼主可以参考下相关案例

hcy1185

liulang0808 发表于 2023-2-6 07:56
https://club.excelhome.net/thread-1385473-1-1.html?_dsign=b73ad3d6
楼主可以参考下相关案例

谢谢版主！
捣鼓了一天，还是个半成品，1-7个工作表的人员数量逐个多时，代码计算正确；反之，前一个工作表的数就计算到后一个工作表里了。

Sub 合并多工作簿第一张表的数据()
Rem 定义变量
Dim DataWb As Workbook, DataSht As Worksheet, DataArr As Variant
Dim ToSht As Worksheet, ToRng As Range, EndRow As Long
Dim FileName As String             '要合并的工作簿名称
Dim dic As Object, Check As Long, Counter As Long, i As Long, j As Long, s As String, k As Long
Dim ts
ts = Timer
Application.ScreenUpdating = False '关闭屏幕更新
Set ToSht = ThisWorkbook.Worksheets(1) '将对象引用分配给变量
ToSht.Rows("7:1048576").Clear      '清除原有数据
FileName = Dir(ThisWorkbook.Path & "\工资核算Excel文件\*.xls?") '返回文件的完整路径
Set dic = CreateObject("scripting.dictionary")
Rem 循环工作簿之工作表
Check = True: Counter = 0       '设置变量初始值。
Do While FileName <> ""
    Counter = Counter + 1       '计数器加一。
    Workbooks.Open FileName:=ThisWorkbook.Path & "\工资核算Excel文件\" & FileName '多字符 (*) 、单字符 (?)
    Set DataWb = ActiveWorkbook '当前活动工作簿
    Set DataSht = DataWb.Worksheets(1) '工作簿的第一个工作表
    EndRow = DataSht.Range("B1048576").End(xlUp).Row '工号列最后行
    DataArr = DataSht.Range("A4").Resize(EndRow - 3, 14).Value '不同的工作表如何将不同的列写入数组
    For i = 1 To UBound(DataArr, 1)
        s = DataArr(i, 2)
        If dic.Exists(s) Then
            dic.Item(s) = "" '如果"s"已存在则为空
            dic(s) = DataArr(i, 6)
        Else
            dic.Item(s) = DataArr(i, 6)
            dic(s) = DataArr(i, 6) '如果"s"不存在则新添
        End If
    Next
    ToSht.Cells(7, "b").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) '工号
    If Counter >= 1 And Counter < 7 Then
        ToSht.Cells(7, 6 + Counter).Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
    End If
    For j = 7 To ToSht.Range("B1048576").End(xlUp).Row
    For i = 1 To UBound(DataArr, 1)
        If ToSht.Cells(j, "b") = DataArr(i, 2) Then
            ToSht.Cells(j, "c") = DataArr(i, 3)  '单位
            ToSht.Cells(j, "d") = DataArr(i, 4)  '姓名
            ToSht.Cells(j, "e") = DataArr(i, 5)  '职务
            If Counter < 7 And ToSht.Cells(j, "b") = DataArr(i, 2) Then
                ToSht.Cells(j, "f") = DataArr(i, 7)  '出勤
            End If
            If Counter = 7 Then '扣除款项
                ToSht.Cells(j, 14) = DataArr(i, 7): ToSht.Cells(j, 15) = DataArr(i, 8)
                ToSht.Cells(j, 16) = DataArr(i, 9): ToSht.Cells(j, 17) = DataArr(i, 10)
                ToSht.Cells(j, 18) = DataArr(i, 11): ToSht.Cells(j, 19) = DataArr(i, 12)
                ToSht.Cells(j, 20) = DataArr(i, 13): ToSht.Cells(j, 21) = DataArr(i, 14)
            End If
        End If
    Next
    Next j
    For k = 1 To dic.Count
        ToSht.Cells(k + 6, "a") = k '序号
    Next
    DataWb.Close savechanges:=False
    FileName = Dir
Loop
Set dic = Nothing
Application.ScreenUpdating = True '打开屏幕更新
MsgBox "运行时间为 " & Timer - ts & " 秒" '计时结束消息对话框
End Sub

hcy1185

标黄色的单元格不应该有数据，其他都正确，请老师指教！谢谢！

wxxydl

我给你做了一个  看一下合适吗？

hcy1185

wxxydl 发表于 2023-2-7 21:49
我给你做了一个  看一下合适吗？

你好！谢谢指导！能否加上注释，没太看明白。
另外请教一下老师！
第一循环时字典里已经存在关键字与值，在第二次循环时，关键字对应的是0值，如何把原来字典里的关键字保留，把对应值修改为“0”？谢谢！