跨加密工作簿 横向匹配判断输入数据

CYZ凡星点点

各位老师，怎么在不清除 E:\总单.xls（表2）原有数据

通过（按钮1）将信息工作簿（表1）X2姓名右边( Y2,Z2,AA2)内容复制 ，X-AA列可能1至5行
匹配汇总到 E:\总单.xls（表2）B列相同姓名右边空单元格处,粘贴3行
如果（表2）同姓名右边，已有相同日期时间和金额，则不复制，

  工作簿修改密码（123），工作表密码（456），能实现吗？

fzxba

文件夹 (3).rar (29.98 KB, 下载次数: 14)

2024-2-16 14:43 上传

点击文件名下载附件

CYZ凡星点点

fzxba 发表于 2024-2-16 14:43

fzxba老师，会出现运行错误

fzxba

CYZ凡星点点 发表于 2024-2-16 16:47
fzxba老师，会出现运行错误

要附件的……

CYZ凡星点点

fzxba 发表于 2024-2-16 16:53
要附件的……

刚打开能运行，重新换姓名价格，就出现错误

fzxba

CYZ凡星点点 发表于 2024-2-16 19:18
刚打开能运行，重新换姓名价格，就出现错误

你刚给的附件，在Excel365中连击20次，又在WPS中连击20次，均无任何错误提示。

再资确认能在这里正常运行你的原因不知解决不了.rar (101.39 KB, 下载次数: 9)

2024-2-17 08:19 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.2.16
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path
   
6.     f = p & "\总单放在E盘\总单.xls"  '//文件路径按实际改一下
   
7.     wbmm = "123": shtmm = "456"
   
8.     Set ws = ThisWorkbook
   
9.     Set sh = ws.Sheets("Sheet1")
   
10.     With sh
    
11.         .Unprotect Password:=shtmm
    
12.         r = .Cells(Rows.Count, "x").End(3).Row
    
13.         arr = .Range("x1:aa" & r)
    
14.         For i = 2 To UBound(arr)
    
15.             s = arr(i, 1)
    
16.             If arr(i, 2) <> Empty Then
    
17.                 If Not d.exists(s) Then
    
18.                     d(s) = .Cells(i, "y").Resize(1, 3)
    
19.                 End If
    
20.             End If
    
21.         Next
    
22.         .Protect Password:=shtmm
    
23.     End With
    
24.     On Error Resume Next
    
25.     Set wb = Workbooks.Open(f, 0, False, , wbmm, wbmm)
    
26.     With wb.Sheets("Sheet2")
    
27.         r = .Cells(Rows.Count, 1).End(3).Row
    
28.         For i = 4 To UBound(arr) Step 3
    
29.             c = .Cells(i, Columns.Count).End(xlToLeft).Column
    
30.             s = .Cells(i, 2)
    
31.             If d.exists(s) Then
    
32.                 If .Cells(i, c) <> d(s)(1, 1) Then
    
33.                     c = c + 1
    
34.                     t = d(s)
    
35.                     For x = 1 To 3
    
36.                         .Cells(i + x - 1, c) = d(s)(1, x)
    
37.                     Next
    
38.                 End If
    
39.             End If
    
40.         Next
    
41.     End With
    
42.     wb.Close 1
    
43.     Set d = Nothing
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

CYZ凡星点点

fzxba 发表于 2024-2-16 19:27
你刚给的附件，在Excel365中连击20次，又在WPS中连击20次，均无任何错误提示。

回来我也多次执行没出现问题
但是只要把24年01月03日-09时12分改成24年01月04日-09时12分然后下拉
再次执行就会出现错误

fzxba

CYZ凡星点点 发表于 2024-2-17 09:39
回来我也多次执行没出现问题
但是只要把24年01月03日-09时12分改成24年01月04日-09时12分然后下拉
再次 ...