有条件比对

xing_chen · 发表于 2023-2-7 18:58

老师，有簿12张表，想对每张表中同家公司2笔以上业务，金额一致但列的收支方向不一致，或正负可以相抵的，标红；敬请老师赐教。谢谢

liulang0808 · 发表于 2023-2-7 19:53

Sub test()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each sh In Sheets
      sh.Select
      d.RemoveAll
      r = sh.Cells(Rows.Count, 1).End(3).Row
      If r > 2 Then
         arr = sh.[a1].CurrentRegion
         For j = 2 To UBound(arr)
            If Not d.exists(j) Then
                  For i = j + 1 To UBound(arr)
                     If arr(j, 2) = arr(i, 2) And Not d.exists(i) Then
                        If Len(arr(j, 5)) > 0 Then
                              If arr(j, 5) + arr(i, 5) = 0 Or arr(j, 5) - arr(i, 4) = 0 Then
                                 Cells(j, 2).Resize(1, 5).Interior.ColorIndex = 7
                                 Cells(i, 2).Resize(1, 5).Interior.ColorIndex = 7
                                 d(i) = ""
                              End If
                        Else
                              If arr(j, 4) + arr(i, 4) = 0 Or arr(j, 4) - arr(i, 5) = 0 Then
                                 Cells(j, 2).Resize(1, 5).Interior.ColorIndex = 7
                                 Cells(i, 2).Resize(1, 5).Interior.ColorIndex = 7
                                 d(i) = ""
                              End If
                        End If
                     End If
                  Next i
            End If
         Next j
      End If
Next sh
Application.ScreenUpdating = True
End Sub

liulang0808 · 发表于 2023-2-7 19:56

供参考。。。。。

xing_chen · 发表于 2023-2-7 21:33

liulang0808 发表于 2023-2-7 19:56
供参考。。。。。

谢谢老师！运行如愿。

liulang0808 · 发表于 2023-2-7 23:05

xing_chen 发表于 2023-2-7 21:33
谢谢老师！运行如愿。

Sub test()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each sh In Sheets
      d.RemoveAll
      r = sh.Cells(Rows.Count, 1).End(3).Row
      If r > 2 Then
         arr = sh.[a1].CurrentRegion
         For j = 2 To UBound(arr)
            If Not d.exists(j) Then
                  For i = j + 1 To UBound(arr)
                     If arr(j, 2) = arr(i, 2) And Not d.exists(i) Then
                        If Len(arr(j, 5)) > 0 Then
                              If arr(j, 5) + arr(i, 5) = 0 Or arr(j, 5) - arr(i, 4) = 0 Then
                                 sh.Cells(j, 2).Resize(1, 5).Interior.ColorIndex = 3
                                 sh.Cells(i, 2).Resize(1, 5).Interior.ColorIndex = 3
                                 d(i) = ""
                                 Exit For
                              End If
                        Else
                              If arr(j, 4) + arr(i, 4) = 0 Or arr(j, 4) - arr(i, 5) = 0 Then
                                 sh.Cells(j, 2).Resize(1, 5).Interior.ColorIndex = 3
                                 sh.Cells(i, 2).Resize(1, 5).Interior.ColorIndex = 3
                                 d(i) = ""
                                 Exit For
                              End If
                        End If
                     End If
                  Next i
            End If
         Next j
      End If
Next sh
Application.ScreenUpdating = True
End Sub
代码做了微调，之前的存在问题

准提部林 · 发表于 2023-2-8 16:06

G列放兩兩相比對的序號, 可篩選檢查//

TEST001.rar (13.88 KB, 下载次数: 12)

准提部林 · 发表于 2023-2-8 18:24

行號連接改用空格//避免留下尾巴

TEST001-1.rar (13.93 KB, 下载次数: 13)

xing_chen · 发表于 2023-2-8 20:58

准提部林发表于 2023-2-8 16:06
G列放兩兩相比對的序號, 可篩選檢查//

谢谢老师！运行如愿。你还帮我加了辅助列，这样方便再核查了。谢谢！
抱歉！另老师！花在旅途，估计明天送达。

xing_chen · 发表于 2023-2-8 20:58

准提部林发表于 2023-2-8 18:24
行號連接改用空格//避免留下尾巴

谢谢老师！运行如愿。你还帮我加了辅助列，这样方便再核查了。谢谢！
抱歉！另老师！花在旅途，估计明天送达。

准提部林 · 发表于 2023-2-9 09:53

xing_chen 发表于 2023-2-8 20:58
谢谢老师！运行如愿。你还帮我加了辅助列，这样方便再核查了。谢谢！
抱歉！另老师！花在旅途，估计明天 ...

利用G列檢查, 確定無誤後,
以G列作排序, 紅色的都排在上面, 可以一次選取刪除

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

[求助] 有条件比对

评分

评分

评分

评分