怎么用vba实现多条件匹配？

fengziiiiii · 发表于 2024-1-23 22:25

如图这是我的部分原始数据表

我想要的效果

绞尽脑汁也只写了方案行和姓名行，而且方法特别蠢，献丑了。

Sub 分析()
On Error Resume Next
Dim originalArray As Variant
Dim uniqueArray As Variant
Dim dict As Object
Dim item As Variant
Dim i As Long
Dim lastRow As Long
Set datasheet = ThisWorkbook.Sheets("销售总览")
Set analysis = ThisWorkbook.Sheets("销售分析")
lastRow = analysis.Cells(analysis.Rows.Count, "A").End(xlUp).Row
For j = 10 To lastRow
analysis.Rows(j).Clear
Next j
If datasheet Is Nothing Or analysis Is Nothing Then
MsgBox "Worksheet not found!", vbExclamation
Exit Sub
End If
'数据范围
originalArray = datasheet.Range("A8:A" & datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(originalArray, 1) To UBound(originalArray, 1)
item = originalArray(i, 1)
If Not dict.Exists(item) Then
dict.Add item, Nothing
End If
Next i
uniqueArray = dict.Keys
analysis.Range("A10").Value = "姓名"
analysis.Range("B10").Resize(1, UBound(uniqueArray) + 1).Value = uniqueArray
On Error GoTo 0
Call RemoveDuplicates
End Sub
Sub RemoveDuplicates()
On Error Resume Next
Dim originalArray As Variant
Dim uniqueArray As Variant
Dim dict As Object
Dim item As Variant
Dim i As Long
Set datasheet = ThisWorkbook.Sheets("销售总览")
Set analysis = ThisWorkbook.Sheets("销售分析")
If datasheet Is Nothing Or analysis Is Nothing Then
MsgBox "Worksheet not found!", vbExclamation
Exit Sub
End If
' 数据改范围
originalArray = datasheet.Range("B8:B" & datasheet.Cells(datasheet.Rows.Count, 2).End(xlUp).Row).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(originalArray, 1) To UBound(originalArray, 1)
item = originalArray(i, 1)
If Not dict.Exists(item) Then
dict.Add item, Nothing
End If
Next i
uniqueArray = dict.Keys
analysis.Range("A11").Resize(UBound(uniqueArray) + 1, 1).Value = Application.WorksheetFunction.Transpose(uniqueArray)
On Error GoTo 0
End Sub

复制代码

销售.zip (34.05 KB, 下载次数: 12)
麻烦大家了。。谢谢

excel玉米 · 发表于 2024-1-24 04:37

可以用数据透视表来做的

ykcbf1100 · 发表于 2024-1-24 08:05

楼主的代码应该是AI写的，人类一般不会这样写。

3190496160 · 发表于 2024-1-24 11:57

Sub 分析()
Dim rn As Range
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
zd = Sheets("销售分析").ComboBox1.Text
With Sheets("销售总览")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a7:m" & r)
Set rn = .Rows(7).Find(zd, , , , , , 1)
If rn Is Nothing Then MsgBox "找不到要查询的商品名称": End
lh = rn.Column
End With
ReDim br(1 To UBound(ar), 1 To 500)
br(1, 1) = "姓名"
m = 1: k = 1
For i = 2 To UBound(ar)
If Trim(ar(i, lh)) <> "" Then
      t = d(ar(i, 2))
      If t = "" Then
         k = k + 1
         d(ar(i, 2)) = k
         t = k
         br(k, 1) = ar(i, 2)
      End If
      y = d(ar(i, 1))
      If y = "" Then
         m = m + 1
         d(ar(i, 1)) = m
         y = m
         br(1, m) = ar(i, 1)
      End If
      br(t, y) = ar(i, lh)
End If
Next i
With Sheets("销售分析")
.UsedRange.Offset(9) = Empty
.[a10].Resize(k, m) = br
End With
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-1-24 11:58

销售.rar (32.62 KB, 下载次数: 41)

kittli · 发表于 2024-1-24 12:59

交作业！！

ph378 · 发表于 2024-12-9 17:39

学习学习了

gwjkkkkk · 发表于 2024-12-9 19:10

请参考。。。

gwjkkkkk · 发表于 2024-12-9 19:12

请参考。。。

z865593849 · 发表于 2024-12-10 09:02

数据转置

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

[求助] 怎么用vba实现多条件匹配？

评分