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

likun17

哪位大神帮忙看一下啊，如何用VBA提取对应顾问对应星级会员ID呢？急求！！！

一把小刀闯天下

'应该差不多，自己测试一下

Option Explicit

Sub test()
  Dim arr, dic, pos, i, j, k, a, mark, m, n, sht, key, max
  Set dic = CreateObject("scripting.dictionary")
  mark = "一二三"
  arr = Sheets("sheet2").[a1].CurrentRegion
  ReDim brr(1 To 10 ^ 3, 1 To UBound(arr, 1), 1 To 3)
  ReDim pos(1 To 10 ^ 3, 1 To 3), max(1 To UBound(arr, 1))
  For i = 2 To UBound(arr, 1)
    a = Val(InStr(mark, Left(arr(i, 2), 1)))
    If dic.exists(arr(i, 3)) Then
      pos(dic(arr(i, 3)), a) = pos(dic(arr(i, 3)), a) + 1
      brr(dic(arr(i, 3)), pos(dic(arr(i, 3)), a), a) = arr(i, 1)
      If max(dic(arr(i, 3))) < pos(dic(arr(i, 3)), a) Then _
        max(dic(arr(i, 3))) = pos(dic(arr(i, 3)), a)
    Else
      m = m + 1: dic(arr(i, 3)) = m
      pos(m, a) = pos(m, a) + 1: max(m) = pos(m, a)
      brr(m, pos(m, a), a) = arr(i, 1)
    End If
  Next
  For Each key In dic.keys
    i = 0
    For Each sht In Sheets
      If key = sht.Name Then i = 1: Exit For
    Next
    If i = 0 Then
      Sheets.Add
      With ActiveSheet
        .Name = key
        .[a1].Resize(, 3) = Split("一星会员 二星会员 三星会员")
      End With
    Else
      Sheets(key).[a2].Resize(Rows.Count - 1, 3).ClearContents
    End If
    ReDim arr(1 To max(dic(key)), 1 To 3)
    For i = 1 To UBound(arr, 1)
      For j = 1 To UBound(arr, 2)
        arr(i, j) = brr(dic(key), i, j)
    Next j, i
    Sheets(key).[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  Next
End Sub

jiminyanyan

很好!！！！！！！！！！！！！！！

LMY123

字典拆分成工作表并转置

duquancai

请测试》》》》》》》》》》》》》》》》》》》自己先写个函数 按照“销售顾问”进行拆分工作表！

1. Sub main()
   
2.     Dim conn As Object, s$, sh As Worksheet, a
   
3.     Set conn = CreateObject("adodb.connection")
   
4.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;;data source=" & ThisWorkbook.FullName
   
5.     a = Array("一星会员", "二星会员", " 三星会员")
   
6.     For Each sh In Worksheets
   
7.         If sh.Name <> "Sheet2" Then
   
8.             For i = 0 To 2
   
9.                 s = "select 会员ID from [Sheet2$A:C] where 星级='" & a(i) & "' and 销售顾问='" & sh.Name & "'"
   
10.                 sh.Cells(2, i + 1).CopyFromRecordset conn.Execute(s)
    
11.             Next
    
12.         End If
    
13.     Next
    
14. End Sub

复制代码

duquancai

我还是给你写完整吧！免得说我不地道。

1. Sub main()
   
2.     Dim conn As Object, s$, sh As Worksheet, a, b
   
3.     Set conn = CreateObject("adodb.connection")
   
4.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;;data source=" & ThisWorkbook.FullName
   
5.     a = 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.     s = "select 销售顾问 from [Sheet2$A:C] where 销售顾问<>'' group by  销售顾问"
    
14.     b = conn.Execute(s).GetRows
    
15.     For j = 0 To UBound(b, 2)
    
16.         Sheets.Add after:=Sheets(Sheets.Count)
    
17.         Sheets(Sheets.Count).Name = b(0, j)
    
18.         Sheets(Sheets.Count).[a1:c1] = a
    
19.         For i = 0 To 2
    
20.             s = "select 会员ID from [Sheet2$A:C] where 星级='" & a(i) & "' and 销售顾问='" & b(0, j) & "'"
    
21.             Sheets(Sheets.Count).Cells(2, i + 1).CopyFromRecordset conn.Execute(s)
    
22.         Next
    
23.     Next
    
24. End Sub

复制代码

schliemann

mark一下，分类：ADODB

aecn

mark一下,方便用时好找

likun17

duquancai 发表于 2018-7-1 11:05
我还是给你写完整吧！免得说我不地道。

运行后提示自动化错误呢

duquancai

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

这种类似的错误，自己想办法解决！别艾特我。