[已解决]请教条件汇总，感谢!

szgzxgcx · 发表于 2023-12-23 10:10

本帖最后由 szgzxgcx 于 2023-12-23 16:37 编辑

请见附件，感谢!

最佳答案

心正意诚身修

2023-12-23 14:40

Sub kk()
Dim oldarr(), a As Single, d
oldarr = Range("a2").CurrentRegion
a = UBound(oldarr)
Set d = CreateObject("scripting.dictionary")
For I = 2 To a
If Not d.exists(oldarr(I, 3)) Then
d(oldarr(I, 3)) = oldarr(I, 3)
d(oldarr(I, 3)) = oldarr(I, 2) & "*" & oldarr(I, 1) & "*" & oldarr(I, 4) & "*" & oldarr(I, 5)
Else
d(oldarr(I, 3)) = d(oldarr(I, 3)) & ";" & oldarr(I, 2) & "*" & oldarr(I, 1) & "*" & oldarr(I, 4) & "*" & oldarr(I, 5)
End If
Next
Range("g2").Resize(d.Count, 1) = Application.Transpose(d.keys)
Range("h2").Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub

复制代码

见附件

心正意诚身修 · 发表于 2023-12-23 14:40

Sub kk()
Dim oldarr(), a As Single, d
oldarr = Range("a2").CurrentRegion
a = UBound(oldarr)
Set d = CreateObject("scripting.dictionary")
For I = 2 To a
If Not d.exists(oldarr(I, 3)) Then
d(oldarr(I, 3)) = oldarr(I, 3)
d(oldarr(I, 3)) = oldarr(I, 2) & "*" & oldarr(I, 1) & "*" & oldarr(I, 4) & "*" & oldarr(I, 5)
Else
d(oldarr(I, 3)) = d(oldarr(I, 3)) & ";" & oldarr(I, 2) & "*" & oldarr(I, 1) & "*" & oldarr(I, 4) & "*" & oldarr(I, 5)
End If
Next
Range("g2").Resize(d.Count, 1) = Application.Transpose(d.keys)
Range("h2").Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub

复制代码

见附件

szgzxgcx · 发表于 2023-12-23 16:35

心正意诚身修发表于 2023-12-23 14:40
见附件

非常感谢

心正意诚身修 · 发表于 2023-12-30 15:35

szgzxgcx 发表于 2023-12-23 16:35
非常感谢

不客气

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