关于跨表查找写值问题，改代码

sampsonpon

如下图，模块2里。因为代码运行太慢，修改下使其快速计算

目的是：
通过本表B&C匹配指定路径下"test.xlsx"工作簿里"Database"工作表的A列找到C列值写入到此表AD列

Yalishanda30

..........

quqiyuan

参与一下，仅供参考。。。
加上数组，速度提速

quqiyuan

代码如下。。。
Sub UpdateSKUList()
    Application.ScreenUpdating = False
    Dim sourceWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceWorksheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim skuValue As Variant
    Dim sourceFilePath As String

    ' 设置源工作簿的文件路径
'    sourceFilePath = "P:\PlG Files\test.xlsb"
    sourceFilePath = "K:\excelhome\test.xlsb"
    ' 以只读方式打开源工作簿
    Set sourceWorkbook = Workbooks.Open(sourceFilePath, ReadOnly:=True)
    Set sht = sourceWorkbook.Worksheets("Database")
    brr = Intersect(sht.UsedRange, sht.Columns("a:c"))

    ' 设置目标工作表
    Set targetWorksheet = ThisWorkbook.Worksheets("LIST")
   
    ' 获取目标工作表的最后一行
    With targetWorksheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        c = .Cells(1, .Columns.Count).End(1).Column
        arr = .Range(.[a1], .Cells(lastRow, c))
    End With
   
    ReDim crr(1 To lastRow - 1, 1 To 1)
   
    ' 遍历目标工作表的B列，查找匹配的SKU值并写入AD列
    For i = 2 To lastRow ' 假设从第2行开始，因为通常第一行是标题行
'        If IsEmpty(targetWorksheet.Cells(i, "Q")) And Not IsEmpty(targetWorksheet.Cells(i, "I")) Then
            skuValue = Application.Match(arr(i, 2) & arr(i, 3), Application.Index(brr, , 1), 0)
            If Not IsError(skuValue) Then
                crr(i - 1, 1) = brr(skuValue, 3)
            End If
'        End If
    Next i
    targetWorksheet.[ad2].Resize(lastRow - 1) = crr
    ' 关闭源工作簿，不保存更改
    sourceWorkbook.Close SaveChanges:=False
    Beep
    Application.ScreenUpdating = True
End Sub

sampsonpon

Yalishanda30 发表于 2024-9-12 15:00
..........

这里问什么是27？

Yalishanda30

sampsonpon 发表于 2024-9-12 15:32
这里问什么是27？

有空看看二位数组的知识就懂了

Qs18

1. Sub qs()
   
2.     Dim arr, i, dic, p, xb As Workbook
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Application.ScreenUpdating = False
   
6.     Set xb = Workbooks.Open(p & "test.xlsb", 0)
   
7.     With xb
   
8.         r = .Sheets("Database").Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .Sheets("Database").Range("a1").Resize(r, 3).Value
   
10.         xb.Close (0)
    
11.    
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 1)
    
15.         If Not dic.exists(s) Then
    
16.             dic(s) = arr(i, 3)
    
17.         End If
    
18.     Next
    
19.     With Sheet1
    
20.     rw = .Cells(Rows.Count, 2).End(3).Row
    
21.     brr = .Range("b2:c" & rw).Value
    
22.     ReDim crr(1 To UBound(brr), 1 To 1)
    
23.     For i = 1 To UBound(brr)
    
24.         ss = brr(i, 1) & brr(i, 2)
    
25.         If dic.exists(ss) Then
    
26.             crr(i, 1) = dic(ss)
    
27.         End If
    
28.     Next
    
29.     .Range("ad2").Resize(UBound(brr), 1) = crr
    
30.     End With
    
31. Application.ScreenUpdating = True
    
32. MsgBox "完成！"
    
33. End Sub
    

复制代码

Qs18

试试。。。。。。。

Qs18

试试。。。。。。。

z865593849

find 方法 ，2.9秒