跨工作簿匹配判断输入数据

CYZ凡星点点

怎么在不清除 E:\总单.xlsm（资料）原有数据
通过（按钮1）将信息工作簿（单价）B2姓名右边 C2-E2列内容
匹配汇总到 E:\总单.xlsm（资料）第2行相同姓名下面空单元格处,
如果（资料）同姓名下，已有相同日期时间和金额，则不复制，
E盘总单工作簿修改密码（123），资料工作表密码（456），
那位老师能实现

fzxba

1. Sub test0()
   
2. 
   
3.   Dim strFile As String
   
4. '  With Application.FileDialog(msoFileDialogOpen)
   
5. '    .InitialFileName = ThisWorkbook.Path
   
6. '    With .Filters
   
7. '      .Clear
   
8. '      .Add "Excel文件(xls*)", "*.xls*"
   
9. '    End With
   
10. '    .AllowMultiSelect = False
    
11. '    If .Show Then strFile = .SelectedItems(1) Else Exit Sub
    
12. '  End With
    
13. 
    
14.   strFile = "F:\总单.xlsm"
    
15.   If Dir(strFile) = "" Then MsgBox strFile & " 文件不存在！", 64: Exit Sub
    
16.   
    
17.   Application.ScreenUpdating = False
    
18.   
    
19.   Dim ar, br, cr() As Long, Dict As Object
    
20.   Dim wkb As Workbook, wks As Worksheet
    
21.   Dim i As Long, j As Long, idx As Long, pos As Long
    
22.   
    
23.   pos = 666
    
24.   
    
25.   Set Dict = CreateObject("Scripting.Dictionary")
    
26.   Set wkb = Workbooks.Open(strFile, False, , , 123, 123)
    
27.   Set wks = wkb.Worksheets("资料")
    
28.   With wks
    
29.     .Unprotect 456
    
30.     With .Range("A1").CurrentRegion
    
31.       br = Application.Rept(.Rows(2), 1)
    
32.       ar = .Offset(2).Resize(pos)
    
33.       ReDim cr(1 To UBound(br))
    
34.     End With
    
35.     ar(pos, 2) = 0
    
36.     For j = 1 To UBound(br) Step 3
    
37.       Dict.Add br(j), j
    
38.       cr(j) = .Cells(1, j).End(xlDown).Row - 2
    
39.       ar(pos, j) = "|"
    
40.       For i = 1 To cr(j)
    
41.         ar(pos, j) = ar(pos, j) & ar(i, j) & "|" & ar(i, j + 1) & "|" & ar(i, j + 2) & "|"
    
42.       Next
    
43.     Next
    
44. End With
    
45.   br = ThisWorkbook.Worksheets("单价").Range("A1").CurrentRegion.Offset(, 1).Resize(, 4)
    
46.   
    
47.   For i = 2 To UBound(br)
    
48.     If Dict.exists(br(i, 1)) Then
    
49.       idx = Dict(br(i, 1))
    
50.       If InStr(ar(pos, idx), "|" & br(i, 2) & "|" & br(i, 3) & "|" & br(i, 4) & "|") = 0 Then
    
51.         ar(pos, 2) = ar(pos, 2) + 1
    
52.         cr(idx) = cr(idx) + 1
    
53.         For j = 2 To UBound(br, 2)
    
54.           ar(cr(idx), idx + j - 2) = br(i, j)
    
55.           ar(pos, idx) = ar(pos, idx) & br(i, j) & "|"
    
56.         Next
    
57.       End If
    
58.     End If
    
59.   Next
    
60.   
    
61.   wks.Range("A3").Resize(WorksheetFunction.Max(cr), UBound(ar, 2)) = ar
    
62.   wks.Protect 456
    
63.   Set wks = Nothing
    
64.   wkb.Close True
    
65.   Set wkb = Nothing
    
66.   Set Dict = Nothing
    
67.   
    
68.   Application.ScreenUpdating = True
    
69.   MsgBox ar(pos, 2) & " 行更新", 64
    
70. End Sub

复制代码

fzxba

文件夹.rar (500.75 KB, 下载次数: 20)

2024-2-13 09:52 上传

点击文件名下载附件
前面传的有损

CYZ凡星点点

fzxba 发表于 2024-2-13 09:03

非常感谢老师的帮助，就是运行速度好像3-4秒才能完成，不知道是不是我电脑配置低？

fzxba

CYZ凡星点点

fzxba 发表于 2024-2-13 10:56

原来是这样，我一直都没注意，谢谢老师

CYZ凡星点点

fzxba 发表于 2024-2-13 10:56

fzxba老师，名单里面姓名要是换一组，怎么会出现运行错误457？

fzxba

CYZ凡星点点 发表于 2024-2-14 13:02
fzxba老师，名单里面姓名要是换一组，怎么会出现运行错误457？

CYZ凡星点点

fzxba 发表于 2024-2-14 13:21

fzxba老师，修改完会出现子程序或函数未定义，后来我把姓名重复清除，连（资料）里面没有姓名显示公式=0，要全部删除才可以

fzxba

CYZ凡星点点 发表于 2024-2-14 16:58
fzxba老师，修改完会出现子程序或函数未定义，后来我把姓名重复清除，连（资料）里面没有姓名显示公式=0 ...

请传个附件，并确认你描述的问题存在于所传的附件中。

补充：不占楼层，图中你写错，你的是 dictbr (j),j  可这样   dict (  br (j)  )  =   j