跨表怎么查找并填充

小女孩

123.rar (50.1 KB, 下载次数: 26)

2023-7-11 09:47 上传

点击文件名下载附件

哪位老师能帮助一下，我没弄出来，谢谢！

于箱长

              嗯

feilanga

................

ZHLK

Sub demo()
Dim arr()
Dim mybook As Workbook
Dim sht As Worksheet
arr = Sheet1.UsedRange
Set mybook = Workbooks.Open(Filename:=ThisWorkbook.Path & "\b.xls")
For I = 2 To UBound(arr)
    For J = 2 To mybook.ActiveSheet.UsedRange.Rows.Count
        If mybook.ActiveSheet.Cells(J, 1) = arr(I, 2) Then
            mybook.ActiveSheet.Cells(J, 10) = arr(I, 7)
            mybook.ActiveSheet.Cells(J, 11) = arr(I, 8)
            Exit For
        End If
    Next J
Next I
mybook.Save

Workbooks("A.XLSM").Close True

End Sub

shiruiqiang

卫生系统的帮一下了，楼上老师的代码上改了一下

ykcbf1100

附件供参考。。。

cyq4896

参与一下....

gwjkkkkk

ykcbf1100 发表于 2023-7-11 10:54
很奇怪，数据写入后B工作簿后，屏幕不显示内容。
不过，可以通过视图——取消隐藏就可以恢复正常显示。

...

应该是getobject打开的吧，用getobject是隐藏打开，保存后属性是在excel中隐藏状态，换成workbooks.open方式

yynrzwh

1. Sub 查询()
   
2. 
   
3. arr = Sheet1.UsedRange
   
4. Set d = CreateObject("scripting.dictionary")
   
5. ph = ThisWorkbook.Path & "" '本工作簿路径
   
6.     For i = 2 To UBound(arr)
   
7.         d(Trim(arr(i, 2))) = Array(arr(i, 7), arr(i, 8))
   
8.     Next i
   
9.    
   
10.     Set wd = Workbooks.Open(ph & "B.xls") '打开B工作簿
    
11.    
    
12.     With wd.Sheets("费用监测上报明细表（模板）2023_04_25_13_53_5")
    
13.         brr = .UsedRange
    
14.         For i = 2 To UBound(brr)
    
15.             s = Trim(brr(i, 1))
    
16.             If d.exists(s) Then
    
17.                 brr(i, 10) = d(s)(0)
    
18.                 brr(i, 11) = d(s)(1)
    
19.             End If
    
20.         Next i
    
21.         .UsedRange = brr
    
22.     End With
    
23.    
    
24. Set d = Nothing
    
25. Set wd = Nothing
    
26. End Sub
    

复制代码

ykcbf1100

gwjkkkkk 发表于 2023-7-11 11:20
应该是getobject打开的吧，用getobject是隐藏打开，保存后属性是在excel中隐藏状态，换成workbooks.open ...

这样啊，没仔细看呢