求助垮文件查询引用数据

天真无鞋

夸文件查询引用数据，详见附加说明。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.18
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("新数据")
   
6.     p = ThisWorkbook.Path & ""
   
7.     f = p & "Pn\数据源.xlsx"
   
8.     Set wb = Workbooks.Open(f, 0)
   
9.     With wb.Sheets(1)
   
10.         arr = .UsedRange
    
11.         wb.Close False
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = CStr(arr(i, 1))
    
15.         d(s) = i
    
16.     Next
    
17.     With sh
    
18.         r = .Cells(Rows.Count, 2).End(3).Row
    
19.         For i = 4 To r
    
20.             s = CStr(.Cells(i, 2))
    
21.             If d.exists(s) Then
    
22.                 .Cells(i, "AH") = arr(d(s), 4)
    
23.                 .Cells(i, "AI") = arr(d(s), 5)
    
24.                 .Cells(i, "AJ") = arr(d(s), 6)
    
25.                 .Cells(i, "AK") = arr(d(s), 7)
    
26.             End If
    
27.             st = .Cells(i, "AH") & .Cells(i, "AI") & .Cells(i, "AJ") & .Cells(i, "AK")
    
28.             If st <> Empty Then
    
29.                 Set Rng = .Cells(i, 1).Resize(, 37)
    
30.                 Rng.Interior.ColorIndex = 15
    
31.             End If
    
32.         Next
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "OK！"
    
36. End Sub
    
37. 
    

复制代码

excel小白白2

测试数据 - 练习.rar (161.44 KB, 下载次数: 10)

2024-6-18 14:04 上传

点击文件名下载附件

1. Sub 读取文件内容填充到另一表格()
   
2. Rem 首先读取源数据表格内容，作为查找数组
   
3. Rem 如果文件名、文件路径固定，可以直接采用常量读取
   
4. Rem 如果不固定，可以采用调用微软选择文件对话框的方法选取文件（可自行百度、AI工具查看示例代码）
   
5. 
   
6. Rem 文件路径固定的方式
   
7. Dim filePath As String
   
8. filePath = "D:\桌面\Files_includes\Excel_vba\excel vba 学习\数据源.xlsx" '替换为实际文件路径
   
9. Dim wb As Workbook
   
10. Set wb = GetObject(filePath)
    
11. Dim sheet1 As Worksheet
    
12. Set sheet1 = wb.Sheets("清单")
    
13. 
    
14. Dim Data1 As Variant
    
15. Data1 = sheet1.UsedRange.Value
    
16. '这里可以对读取到的数据进行处理
    
17. wb.Close False '闭文件，不保存更改
    
18. Set wb = Nothing

复制代码

参与一下

Qs18

Public Sub chaxun()
Application.ScreenUpdating = False
Dim arr, wb As Workbook, r As Range, rng As Range
Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
Set wb = Workbooks.Open(ThisWorkbook.Path & "\PN\数据源.xlsx", False)
arr = wb.Sheets(1).Range("a1").CurrentRegion.Value
wb.Close
For i = 2 To UBound(arr)
    s = arr(i, 1)
    If Not dic.exists(s) Then
        v = arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6) & "|" & arr(i, 7)
        dic(s) = v
    End If
Next
With Sheet1
Dim rw: rw = .Cells(Rows.Count, 2).End(xlUp).Row
Set rng = .Range("b4:b" & rw)
.Range("a4:ak" & rw).Interior.Pattern = xlNone
For Each r In rng
    k = dic(r.Value)
    If Len(k) > 0 Then
    r.Offset(0, 32).Resize(1, 4) = Split(k, "|")
    r.Offset(0, -1).Resize(1, 37).Interior.ThemeColor = xlThemeColorDark2
    End If
Next
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

Qs18

试一下................

excel小白白2

excel小白白2 发表于 2024-6-18 14:07
参与一下

上传的代码不全，我后面补一楼

excel小白白2

天真无鞋

谢谢各位老师

天真无鞋

excel小白白2 发表于 2024-6-18 14:07
参与一下

你好老师，最后一行的数据无法引用，能否帮忙在改一下代码，谢谢！