[已解决]如何写这个VBA代码

cqfdrslyh · 发表于 2021-8-25 21:05

根据职务，把职务对应的姓名填写在F列、G列、H列下面，如何写VBA代码

最佳答案

excel用户1116

2021-8-26 15:33

Sub Test()
Dim i&, c%, x&, n&, arr, brr, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = [f1].CurrentRegion
For i = 1 To UBound(arr, 2)
      If Len(arr(1, i)) Then d(arr(1, i) & "|c") = i
Next
brr = [a1].CurrentRegion
ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
For i = 2 To UBound(brr)
      c = d(brr(i, 2) & "|c")
      If c > 0 Then
         x = d(brr(i, 2) & "|r")
         If x = 0 Then
            d(brr(i, 2) & "|r") = 1: x = 1
            n = IIf(n > x, n, x)
         Else
            d(brr(i, 2) & "|r") = d(brr(i, 2) & "|r") + 1
            x = d(brr(i, 2) & "|r")
            n = IIf(n > x, n, x)
         End If
         crr(x, c) = brr(i, 1)
      End If
Next
[f2].Resize(n, UBound(crr, 2)) = crr
End Sub

跳转到最佳答案楼层

excel用户1116 · 发表于 2021-8-26 15:33

这个最佳答案由 excel用户1116 给出，感谢 excel用户1116 的回答。

单击隐藏图章

Sub Test()
Dim i&, c%, x&, n&, arr, brr, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = [f1].CurrentRegion
For i = 1 To UBound(arr, 2)
      If Len(arr(1, i)) Then d(arr(1, i) & "|c") = i
Next
brr = [a1].CurrentRegion
ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
For i = 2 To UBound(brr)
      c = d(brr(i, 2) & "|c")
      If c > 0 Then
         x = d(brr(i, 2) & "|r")
         If x = 0 Then
            d(brr(i, 2) & "|r") = 1: x = 1
            n = IIf(n > x, n, x)
         Else
            d(brr(i, 2) & "|r") = d(brr(i, 2) & "|r") + 1
            x = d(brr(i, 2) & "|r")
            n = IIf(n > x, n, x)
         End If
         crr(x, c) = brr(i, 1)
      End If
Next
[f2].Resize(n, UBound(crr, 2)) = crr
End Sub

cqfdrslyh · 发表于 2021-8-26 19:22

本帖最后由 cqfdrslyh 于 2021-8-26 20:30 编辑

excel用户1116 发表于 2021-8-26 15:33
Sub Test()
Dim i&, c%, x&, n&, arr, brr, d As Object
Set d = CreateObject("Scripting.Dicti ..

你好，太谢谢了。我初学，有些看不懂，我进行了初步修改，但不成功，帮我修改一下。谢谢

excel用户1116 · 发表于 2021-8-27 12:14

cqfdrslyh 发表于 2021-8-26 19:22
你好，太谢谢了。我初学，有些看不懂，我进行了初步修改，但不成功，帮我修改一下。谢谢

查找符合要求的姓名(2).zip (24.77 KB, 下载次数: 5)

cqfdrslyh · 发表于 2021-8-27 21:36

excel用户1116 发表于 2021-8-27 12:14

能再次帮助修改一下吗？感谢你的帮助。
我想微信你

excel用户1116 · 发表于 2021-8-28 14:39

本帖最后由 excel用户1116 于 2021-8-28 14:41 编辑

cqfdrslyh 发表于 2021-8-27 21:36
能再次帮助修改一下吗？感谢你的帮助。
我想微信你

查找符合要求的姓名(2).zip (35.68 KB, 下载次数: 3)

		自动登录	找回密码
密码			注册