VBA按条件取值

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     ar = Sheets(" 产品信息 ").[a1].CurrentRegion
   
4.     For i = 4 To UBound(ar)
   
5.         If Len(ar(i, 2)) > 0 Then s = Trim(ar(i, 3))
   
6.         d(s) = ar(i, 2)
   
7.     Next
   
8.     br = [a1].CurrentRegion
   
9.     For i = 3 To UBound(br)
   
10.         s = Trim(br(i, 3))
    
11.          br(i, 2) = d(s)
    
12.     Next
    
13.     [a1].CurrentRegion = br
    
14. End Sub

复制代码

luketools

lsc900707 发表于 2021-1-17 18:34

可以了，非常感谢，送两朵小花表示感谢。

luketools

lsc900707 发表于 2021-1-17 18:34

你好，我需要在产品信息表中的规格前面增加一列产品品牌，需要把产品名称和产品品牌同时引用到库存表中，这个代码应该怎么增加，谢谢！
产品信息增加一列品牌，库存表中也自动引用品牌列，类似这样：

xiangbaoan

Option Compare Text
Option Explicit

Sub DictAndArray() '据13楼图片
  Dim ar, br, d As Object, i As Long, j As Long, y As Long
  Set d = CreateObject("Scripting.Dictionary")
  With Worksheets(2)
    br = .Range("B4:D" & .Cells(.Rows.Count, 4).End(xlUp).Row)
  End With
  With Worksheets(1)
    y = .Cells(.Rows.Count, 4).End(xlUp).Row
    .Range("B3:C" & y).ClearContents
    ar = .Range("B3:D" & y)
  End With
  For i = 1 To UBound(ar)
    If Len(ar(i, 3)) Then d(ar(i, 3)) = i
  Next
  For i = 1 To UBound(br)
    y = d(br(i, 3))
    If y Then
      For j = 1 To 2
        ar(y, j) = br(i, j)
      Next
    End If
  Next
  Worksheets(1).Range("B3").Resize(UBound(ar), 2) = ar
  Set d = Nothing
End Sub