如何用VBA提取对应星级会员ID

Kaohsing

likun17 发表于 2018-7-4 01:04
运行后提示自动化错误呢

这样试试：

1. Sub kao()
   
2.     Dim d As Object, arr, ar, ghb, sh
   
3.     Dim i%
   
4.     Dim skey
   
5.     ghb = Array("一星会员", "二星会员", " 三星会员")
   
6.      For Each sh In Sheets
   
7.         If sh.Name <> "Sheet2" Then
   
8.             Application.DisplayAlerts = False
   
9.             sh.Delete
   
10.             Application.DisplayAlerts = True
    
11.         End If
    
12.     Next
    
13.     Set d = CreateObject("scripting.dictionary")
    
14.     ar = Sheet1.[a1].CurrentRegion
    
15.     For i = 2 To UBound(ar, 1)
    
16.         If d.exists(ar(i, 3)) = False Then Set d(ar(i, 3)) = CreateObject("Scripting.Dictionary")
    
17.         d(ar(i, 3))(ar(i, 2)) = d(ar(i, 3))(ar(i, 2)) & "," & ar(i, 1)
    
18.     Next
    
19.     For Each skey In d.keys
    
20.         Sheets.Add after:=Sheets(Sheets.Count)
    
21.         Sheets(Sheets.Count).Name = skey
    
22.         Sheets(Sheets.Count).[a1:c1] = ghb
    
23.         With ActiveSheet
    
24.             For i = 1 To 3
    
25.                 arr = Split(Mid(d(skey)(ghb(i - 1)), 2), ",")
    
26.                 If UBound(arr) > -1 Then [a2].Offset(0, i - 1).Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
    
27.             Next
    
28.         End With
    
29.     Next
    
30.     MsgBox "ok"
    
31. End Sub
    

复制代码

likun17

好的，感谢。