挨个填

xing_chen

老师！有簿，含有2表，需要提取代码，但欲在汇总表中，根据年初表的品种代码，对汇总表的各部门品种挨个填，我现在只能取1个。若要对其它部门提取，则要重复运行代码。现在想1次性完成对各部门的提取。敬请老师赐教。谢谢

fanyoulin

我看得有点迷，猜测着写的。

全党

是这样吗

1. Sub 提科目代码()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     d.CompareMode = 1
   
4.     arr = Sheets("年初").Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr) '
   
6.         d(arr(i, 1)) = arr(i, 2)
   
7.     Next
   
8.     brr = Sheets("汇总").Range("A1").CurrentRegion
   
9.     For i = 3 To UBound(brr)
   
10.        For j = 2 To UBound(brr, 2) Step 4
    
11.         If d.Exists(brr(i, 1)) Then brr(i, j) = d(brr(i, 1))
    
12.        Next
    
13.     Next
    
14.    
    
15.     Sheets("汇总").Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
16. 
    
17. End Sub

复制代码

？。。。。。。

xing_chen

fanyoulin 发表于 2023-5-30 10:49
我看得有点迷，猜测着写的。

谢谢老师！运行如愿！
抱歉！花在旅途，估计明日下午到

xing_chen

全党 发表于 2023-5-30 10:58
是这样吗
？。。。。。。

谢谢老师！运行如愿！只是有个小细节，有何办法将j设置为文本格式，因为提取的代码变成数字格式了。
抱歉！花在旅途，到时献上

全党

xing_chen 发表于 2023-5-30 13:57
谢谢老师！运行如愿！只是有个小细节，有何办法将j设置为文本格式，因为提取的代码变成数字格式了。
抱 ...

Sub 提科目代码()
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1
    arr = Sheets("年初").Range("A1").CurrentRegion
    For i = 2 To UBound(arr) '
        d(arr(i, 1)) = arr(i, 2)
    Next
    brr = Sheets("汇总").Range("A1").CurrentRegion
    For i = 3 To UBound(brr)
       For j = 2 To UBound(brr, 2) Step 4
       If d.Exists(brr(i, 1)) Then brr(i, j) = d(brr(i, 1))
       Next
    Next
    With Sheets("汇总")
    .Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
    Union(.Columns(2), .Columns(6), .Columns(10), .Columns(14), .Columns(18)).NumberFormat = "@"
    End With
End Sub

xing_chen

全党 发表于 2023-5-30 14:36
Sub 提科目代码()
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1

谢谢老师！运行如愿！
花在旅途到时献上

gwjkkkkk

请参考。。。

ykcbf1100

原代码小改一下。

slonby

=IFERROR(INDIRECT("年初!B"&MATCH(A3,年初!A:A,0)),"")
用公式也可以直接搞定