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

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

"爱疯"老师，麻烦你再帮助改改！

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

zwj8859 发表于 2017-7-4 10:45
"爱疯"老师，麻烦你再帮助改改！

10楼哪儿有问题？

zwj8859 · 发表于 2017-7-4 11:07

谢谢！相减<=0时，不复制，再给改改

爱疯 · 发表于 2017-7-4 11:17

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列相减
            If B(Dic(temp), 4) > A(i, 4) = False Then 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用数组对比筛选4.rar (18.74 KB, 下载次数: 8)

zwj8859 · 发表于 2017-7-4 11:45

“爱疯”老师，A，B相减<=0时，不复制。麻烦你帮助再改改！

爱疯 · 发表于 2017-7-4 12:00

zwj8859 发表于 2017-7-4 11:45
“爱疯”老师，A，B相减

14楼结果哪个地方不对？

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

这个最佳答案由大灰狼1976 给出，感谢大灰狼1976 的回答。

单击隐藏图章

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

复制代码

zwj8859 · 发表于 2017-7-4 15:26

“爱疯”老师，当A，B数量相减<=0时，还是会复制到C区。要求不会复制过去，不知怎样改？另外请问Count = Count + 1: Dic(temp) = Count是什么意思？

zwj8859 · 发表于 2017-7-4 15:31

X

+50/-150

S70

40

40<50,还是复制过去了

爱疯 · 发表于 2017-7-4 15:41

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列相减
            If B(Dic(temp), 4) > A(i, 4) Then 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用数组对比筛选5.rar (19.1 KB, 下载次数: 21)

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