根据现有条件赋值

liumahao

对D列赋值，赋值要求是如果C列的值等于E列的值，那么把F列相应的值赋给D列。比如C列的0和795在F列对应的是1，那么D列所有的0和795都,赋值为1，C列的159在F列对应为2，那么D列所有159对应的都赋值为2.

赋值2.zip (19.92 KB, 下载次数: 7)

2018-7-24 14:29 上传

点击文件名下载附件

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, dic, i
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  ReDim brr(1 To UBound(arr, 1) - 1, 1 To 1)
  For i = 2 To UBound(arr, 1)
    If Len(arr(i, 5)) = 0 Then Exit For
    dic(arr(i, 5)) = arr(i, 6)
  Next
  For i = 2 To UBound(arr, 1)
    If dic.exists(arr(i, 3)) Then brr(i - 1, 1) = dic(arr(i, 3))
  Next
  [d2].Resize(UBound(brr, 1)) = brr
End Sub

liumahao

运行代码提示下标越界怎么办？

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [e1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         d(arr(i, 1)) = arr(i, 2)
   
6.     Next
   
7.     r = Cells(Rows.Count, 3).End(3).Row
   
8.     brr = Range("a1:d" & r)
   
9.     For i = 2 To UBound(brr)
   
10.         If d.exists(brr(i, 3)) Then brr(i, 4) = d(brr(i, 3))
    
11.     Next
    
12.     Range("a1:d" & r) = brr
    
13. End Sub

复制代码

lsc900707

附件供参考：

iwangyi

Sub CC()
Columns("D:D").ClearContents
N = [A65536].End(3).Row
For Each Rng In Range("C2:C" & N)
Set C = Columns(5).Find(Rng, , , 1)
If Not C Is Nothing Then
Rng.Offset(, 1) = C.Offset(, 1).Value
End If: Next
End Sub

iwangyi

附件请参考

liumahao

lsc900707 发表于 2018-9-30 14:31
附件供参考：

你好，为什么这个代码应用到这个附件就无效了呢
工作簿1.zip (11.06 KB, 下载次数: 0)

2018-9-30 15:08 上传

点击文件名下载附件