SUB 代替VLOOKUP()
方法一：
  Dim d, ar, br, cr, wb As Workbook
    Set d = CreateObject("Scripting.Dictionary")
    br = Worksheets("Sheet1").[A1].CurrentRegion  '需要配置的数据表
    ar = Worksheets("R").[A1].CurrentRegion  '目标表
   ReDim CRR(1 To UBound(br) - 1, 1 To 1) '配置表的循环列数
    For I = 2 To UBound(ar)      '从目标表需要关联的字段
        d(ar(I, 4)) = ar(I, 6)
    Next
    For I = 2 To UBound(br)
        CRR(I - 1, 1) = d(br(I, 4))  '将CRR写到BRR表中
    Next
    Worksheets("Sheet1").Range("EJ2").Resize(UBound(br), 1) = CRR '匹配


方法二：
Dim arr, d As Object, CRR '
 Set d = CreateObject("scripting.dictionary")    
arr = Worksheets("基础信息表").[a1].CurrentRegion  
brr = Worksheets("统计结果").[a1].CurrentRegion
For i = 2 To UBound(arr)
  d(arr(i, 1)) = arr(i, 6)
  Next

ReDim CRR(2 To UBound(brr), 1 To 1)  '匹配目标表内容
For J = 2 To UBound(brr)
   CRR(J, 1) = d(brr(J, 2))'''在字典里查找BRR值并返回相应值
   Next
   
   Worksheets("统计结果").[C2].Resize(UBound(CRR) - 1, 1) = CRR
  
  
    Set d = Nothing
  
方法三：多列
Dim arr, d As Object, CRR '数组brr用来存放求和数据    '创建字典
 Set d = CreateObject("scripting.dictionary")    '数组赋值
arr = Worksheets("基础信息表").[a1].CurrentRegion    '重置数组brr大小
brr = Worksheets("统计结果").[a1].CurrentRegion

For i = 2 To UBound(arr)
  d(arr(i, 1)) = arr(i, 6) & "," & arr(i, 7)
  Next

ReDim CRR(2 To UBound(brr), 1 To 1)
ReDim DRR(2 To UBound(brr), 1 To 1)
For J = 2 To UBound(brr)
   If d(brr(J, 2)) <> "" Then
   CRR(J, 1) = Split(d(brr(J, 2)), ",")(0) '在BRR里查找到此名，并返回对应值
   DRR(J, 1) = Split(d(brr(J, 2)), ",")(1)
   Else
   CRR(J, 1) = ""
   DRR(J, 1) = ""
   End If
   Next
   
   Worksheets("统计结果").[C2].Resize(UBound(CRR) - 1, 1) = CRR
   Worksheets("统计结果").[D2].Resize(UBound(CRR) - 1, 1) = DRR
  
  
    Set d = Nothing

END SUB

因为用函数公式，如果数据量大的话，会影响效率，而且会增加文件本身大小，所以想用vba代码替代。
 
以下代码用来实现函数公式sumproduct的功能，实现多条件求和。
 

 Private Sub 多条件求和()
    Dim d, ar, arr, s$, t$, i&
    Set d = CreateObject("Scripting.Dictionary")
    ar = Range("b2:m" & [b65536].End(3).Row)
    arr = Sheet3.Range("b2", Sheet3.[j65536].End(3)).Value
    
    For i = 1 To UBound(arr)
       t = Join(Application.Index(Application.Index(arr, i, 0), Array(1, 2, 3, 4)), ",")
       d(t) = d(t) + arr(i, 8)
    Next
    
    For i = 1 To UBound(ar)
       s = Join(Application.Index(Application.Index(ar, i, 0), Array(1, 2, 3, 4)), ",")
       If d.exists(s) Then ar(i, 11) = d(s) Else ar(i, 11) = ""
    Next
 [b2].Resize(UBound(ar), UBound(ar, 2)) = ar
       
 Set d = Nothing
    
   Call sum2
 
End Sub
 
Sub sum2()
 arr = Range("f2:k" & [f65536].End(3).Row)
 For i = 1 To UBound(arr)
   t1 = arr(i, 1) * arr(i, 2)
   t2 = (arr(i, 1) - arr(i, 4)) * arr(i, 2) + arr(i, 3) * arr(i, 4)
   If arr(i, 4) = "" Then arr(i, 6) = t1 Else arr(i, 6) = t2
 Next
 [f2].Resize(UBound(arr), UBound(arr, 2)) = arr
 End Sub

转自：http://www.pinlue.com/article/2020/05/1810/3210525565219.html

参数：
 
 
  
Code ：查询的内容
  
Zone ：查询的区域
ColumnIndex ：指定返回列的序号
Splitor ：行分隔符

 '连接字符串，类似PHONETIC，但是可以添加分隔符
 Function ConnectString(Zone As range, Splitor As String)
     Dim columnCount As Long, rowsCount As Long
     Dim resultStr As String
     Dim i As Integer, j As Integer
     columnCount = Zone.Columns.Count
     rowsCount = Zone.Rows.Count
     '默认分隔符为 ;
     If Splitor = "" Then
         Splitor = ";"
     End If
     For i = 1 To columnCount Step 1
         For j = 1 To rowsCount Step 1
             If Zone.Cells(j, i) <> "" Then
                 '第一个匹配项，不添加分隔符
                 If resultStr <> "" Then
                     resultStr = resultStr & Splitor
                 End If
                 
                 resultStr = resultStr & Zone.Cells(j, i)
             End If
         Next
     Next
     ConnectString = resultStr
 End Function