[已解决]VBA用数组进行对比筛选

zwj8859 · 发表于 2017-7-4 08:52

求助：VBA用数组进行对比筛选

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-7-4 15:15

Sub aaa()
Dim arr, i&, d As Object, s$, brr, r&, c, crr
Set d = CreateObject("scripting.dictionary")
arr = [a3:d8]
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then d(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = arr(i, 4)
Next i
arr = [f3:i8]
For i = 1 To UBound(arr)
s = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
If arr(i, 1) <> "" And d.exists(s) Then
d(s) = d(s) - arr(i, 4)
End If
Next i
ReDim brr(1 To UBound(arr), 1 To 4)
For Each c In d.keys
If d(c) > 0 Then
r = r + 1
crr = Split(c, ",")
For i = 0 To 2
brr(r, i + 1) = crr(i)
Next i
brr(r, 4) = d(c)
End If
Next c
[l3].Resize(UBound(arr), 4) = brr
End Sub

复制代码

跳转到最佳答案楼层

爱疯 · 发表于 2017-7-4 10:03

Sub test()
Dim Dic, Count, B()
Set Dic = CreateObject("scripting.dictionary")
ReDim B(1 To 10 ^ 4, 1 To 4)
Call Compare(Dic, Count, [A3:D8].Value, B)
Call Compare(Dic, Count, [F3:I8].Value, B)
[L3:O65536] = ""
[L3].Resize(Count, UBound(B, 2)) = B
End Sub

Sub Compare(Dic, Count, A, B)
Dim i, j, temp
For i = 1 To UBound(A)
      If A(i, 4) <> "" Then
         temp = A(i, 1) & A(i, 2) & A(i, 3)
         If Dic.exists(temp) Then
            '已存在，第4列相减
            B(Dic(temp), 4) = B(Dic(temp), 4) - A(i, 4)
         Else
            '不存在，赋值
            Count = Count + 1: Dic(temp) = Count
            For j = 1 To UBound(A, 2)
                  B(Count, j) = A(i, j)
            Next j
         End If
      End If
Next i
End Sub

VBA用数组对比筛选2.rar (18.93 KB, 下载次数: 12)

大灰狼1976 · 发表于 2017-7-4 10:03

以下确认：
1、会不会出现A没有而B有的情况，这种情况下怎么处理；
2、颜色&光度&品种相同的信息会不会在A和B内出现多次，这种情况下怎么处理；

爱疯 · 发表于 2017-7-4 10:07

2楼没考虑多次的情况

zwj8859 · 发表于 2017-7-4 10:09

1、会不会出现A没有而B有的情况，这种情况下怎么处理？这种情况会有，A没有而B有，则不复制。
2、颜色&光度&品种相同的信息会不会在A和B内出现多次，这种情况下怎么处理？不会出现多次（即不会重复）

zwj8859 · 发表于 2017-7-4 10:18

有问题，需要修改。存在问题：1、A没有而B有，则不复制，而现在也复制过去了；2、相减<=0时，也复制过去了。

zwj8859 · 发表于 2017-7-4 10:20

ReDim B(1 To 10 ^ 4, 1 To 4)中的“10 ^ 4”不知什么意思？

zwj8859 · 发表于 2017-7-4 10:29

A、B、C只是标识，主要为你们好理解才弄的，实际中没有标识。

爱疯 · 发表于 2017-7-4 10:37

zwj8859 发表于 2017-7-4 10:20
ReDim B(1 To 10 ^ 4, 1 To 4)中的“10 ^ 4”不知什么意思？

10^4，即10000条，是预测的条数，如不够大，手动修改。

爱疯 · 发表于 2017-7-4 10:43

Option Explicit

Sub test()
Dim Dic, Count, B()
Set Dic = CreateObject("scripting.dictionary")
ReDim B(1 To 10 ^ 4, 1 To 4)
Call Compare(Dic, Count, True, [A3:D8].Value, B)
Call Compare(Dic, Count, False, [F3:I8].Value, B)
[L3:O65536] = ""
[L3].Resize(Count, UBound(B, 2)) = B
End Sub

Sub Compare(Dic, Count, bol, A, B)
Dim i, j, temp
For i = 1 To UBound(A)
      If A(i, 4) <> "" Then
         temp = A(i, 1) & A(i, 2) & A(i, 3)
         If Dic.exists(temp) Then
            '已存在，第4列相减
            B(Dic(temp), 4) = B(Dic(temp), 4) - A(i, 4)
         Else
            '不存在，赋值
            If bol Then
                  Count = Count + 1: Dic(temp) = Count
                  For j = 1 To UBound(A, 2)
                     B(Count, j) = A(i, j)
                  Next j
            End If
         End If
      End If
Next i
End Sub

VBA用数组对比筛选3.rar (19.05 KB, 下载次数: 16)

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