VBA A列名称相同的套数向下填充 弹出列表框或下拉箭头输入A列相同名称首套数

zhangmy66

A列名称相同的套数向下填充；弹出列表框或下拉箭头输入A列相同名称首套数

ykcbf1100

附件供参考。。。

zhangmy66

A列名称相同的套数向下填充；弹出列表框或下拉箭头输入A列相同名称首套数

ykcbf1100

没看懂。二个表内容不是一样吗？

zhangmy66

ykcbf1100 发表于 2024-8-21 09:47
没看懂。二个表内容不是一样吗？

就是套数这个有差别，我想下面的自动填充上，不用往下拖

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2024.8.21
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Dim zrr(1 To 1000)
   
4.     With Sheets("项目(总表）")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 26)
   
7.         For I = 6 To UBound(arr)
   
8.             If arr(I, 1) <> arr(I - 1, 1) Then m = m + 1: zrr(m) = Array(I, I)
   
9.             If I = r Then zrr(m)(1) = r
   
10.             If I < r Then
    
11.                 If arr(I, 1) = arr(I - 1, 1) And arr(I, 1) <> arr(I + 1, 1) Then zrr(m)(1) = I
    
12.             End If
    
13.         Next
    
14.         For x = 1 To m
    
15.             r1 = zrr(x)(0): r2 = zrr(x)(1)
    
16.             n = r2 - r1 + 1
    
17.             st = .Cells(r1, "q").Value
    
18.             .Cells(r1, "q").Resize(n).Value = st
    
19.         Next
    
20.         MsgBox "OK！"
    
21.     End With
    
22. End Sub
    

复制代码