[已解决]如何用vba匹配指定列 大神留步看图

lj3543711

如何通过(商家产品编码)C列匹配[上架活动]表中的（商品编码）来填充商品ID 单位（盒） 商品名称  规格 生产厂家
有效期  原价  销售商圈




列顺序是固定的死的对应的列匹配
拼团申请参考模板表中：商品ID       单位（盒）   商品名称   规格   生产厂家        商品有效期至      原价
               上架活动动：药品ID        单位        通用名     规格    厂家               有效期至     单体采购价   


附件已上传
表格.zip (65.4 KB, 下载次数: 17)

2021-9-22 10:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

风林火山

2021-9-22 12:52

Sub test()
      Dim d, arr, k As Integer, n As Byte
      Set d = CreateObject("scripting.dictionary")
      arr = Sheets("上架活动").Range("a1").CurrentRegion
      For k = 2 To UBound(arr)
            If Not d.exists(arr(k, 4)) Then d(arr(k, 4)) = k
      Next k
      For k = 2 To Cells(Rows.Count, 3).End(3).Row
            n = d(Cells(k, 3).Value)
            Cells(k, 1) = arr(n, 3)
            Cells(k, 2) = arr(n, 10)
            Cells(k, 4) = arr(n, 6)
            Cells(k, 5) = arr(n, 8)
            Cells(k, 6) = arr(n, 9)
            If Len(arr(n, 43)) <> 10 Then Cells(k, 13) = arr(n, 43) & "-01" Else Cells(k, 13) = arr(n, 43)
            Cells(k, 15) = arr(n, 12)
      Next k
      Cells.Font.Size = 10
      
End Sub

跳转到最佳答案楼层

lisongmei

使用公式（v）lookup,index+match,不是很方便吗。

lj3543711

lisongmei 发表于 2021-9-22 10:30
使用公式（v）lookup,index+match,不是很方便吗。

真的不方便 人太多 主要大量时间还要去培训 想着做 傻瓜模式

风林火山

Sub test()
      Dim d, arr, k As Integer, n As Byte
      Set d = CreateObject("scripting.dictionary")
      arr = Sheets("上架活动").Range("a1").CurrentRegion
      For k = 2 To UBound(arr)
            If Not d.exists(arr(k, 4)) Then d(arr(k, 4)) = k
      Next k
      For k = 2 To Cells(Rows.Count, 3).End(3).Row
            n = d(Cells(k, 3).Value)
            Cells(k, 1) = arr(n, 3)
            Cells(k, 2) = arr(n, 10)
            Cells(k, 4) = arr(n, 6)
            Cells(k, 5) = arr(n, 8)
            Cells(k, 6) = arr(n, 9)
            If Len(arr(n, 43)) <> 10 Then Cells(k, 13) = arr(n, 43) & "-01" Else Cells(k, 13) = arr(n, 43)
            Cells(k, 15) = arr(n, 12)
      Next k
      Cells.Font.Size = 10
      
End Sub

lj3543711

风林火山 发表于 2021-9-22 12:52
Sub test()
      Dim d, arr, k As Integer, n As Byte
      Set d = CreateObject("scripting.diction ...

如果按照老师做的  ,追加一下数据  拼团申请参考模板  商品信息     取里面的     商品信息 的预设售价1 对应拼团申请 原价      
商品信息 的最近进价
对应拼团申请 成本价
这样该咋搞呢   谢谢啦

风林火山

Sub test()
      Dim d, arr, k As Integer, n As Integer
      
      On Error Resume Next
      Set d = CreateObject("scripting.dictionary")
      arr = Sheets("上架活动").Range("a1").CurrentRegion
      For k = 2 To UBound(arr)
            If Not d.exists(arr(k, 4)) Then d(arr(k, 4)) = k
      Next k
      For k = 2 To Cells(Rows.Count, 3).End(3).Row
            n = d(Cells(k, 3).Value)
            Cells(k, 1) = arr(n, 3)
            Cells(k, 2) = arr(n, 10)
            Cells(k, 4) = arr(n, 6)
            Cells(k, 5) = arr(n, 8)
            Cells(k, 6) = arr(n, 9)
            If Len(arr(n, 43)) <> 10 Then Cells(k, 13) = arr(n, 43) & "-01" Else Cells(k, 13) = arr(n, 43)
            Cells(k, 15) = arr(n, 12)
      Next k
      d.RemoveAll
      Erase arr
      arr = Sheets("商品信息").Range("a1").CurrentRegion
      For k = 2 To UBound(arr)
            If Not d.exists(arr(k, 1)) Then d(arr(k, 1)) = k
      Next k
      For k = 2 To Cells(Rows.Count, 3).End(3).Row
            n = d(Cells(k, 3).Value)
            Cells(k, 14) = arr(n, 14)
            Cells(k, 16) = arr(n, 15)
      Next k
      Cells.Font.Size = 10
      
End Sub