Hàm Non-Intersect – Tìm vùng không giao nhau với VBA

Chia sẻ bởi:hands

★★★★★

‹ Nhờ anh chị em giúp đỡ làm... DatePickerXL – Add-in Lịch để chọn ngày... ›

Quảng cáo

Trong quá trình lập trình với VBA thì tôi nhận thấy VBA không có Phương thức lấy đối tượng Range không giao nhau giữa tập hợp các đối tượng Range khác nhau. Trong VBA có các phương thức như: gộp đối tượng Range bằng hàm Union, lấy đối tượng Range giao nhau bằng Hàm Intersect. Mặc dù tôi đã tham khảo một số Code trên tìm kiếm Google, nhưng các đoạn code ấy thường hay dùng bẫy lỗi hoặc là chưa được tối ưu. Vì vậy hôm nay tôi đã bỏ chút ít thời gian để viết ra hàm NonIntersect – Phương thức lấy đối tượng Range không giao nhau giữa tập hợp các đối tượng Range khác nhau.
———————————————————————-
Hàm NonIntersect là gì?
Trong VBA hàm Intersect sẽ trả về đối tượng Range giao nhau giữa tập hợp các đối tượng Range khác nhau.
Thì hàm NonIntersect sẽ là ngược lại của hàm Intersect, hàm sẽ chỉ lấy các đối tượng Range không giao nhau giữa tập hợp các đối tượng Range khác nhau.

Hàm NonIntersect nhận 3 đối số truyền vào:
1. RngA As Range: Đối tượng Range A
2. RngB As Range: Đối tượng Range B
3. NonOfA As Boolean: Chỉ lấy các đối tượng không giao nhau của Đối tượng Range A

Sử dụng hàm:

Dim Rng As Range
Set Rng = NonIntersect(Cells, Range("A1:D10"), False )

———————————————————————-
Hàm paNonIntersect là gì? ở hàm NonIntersect chỉ nhận 2 đối tượng Range, vì vậy hàm paNonIntersect được tạo ra để nhận nhiều hơn 1 Đối tượng Range (Ít nhất là 2 đối tượng Range, nhiều nhất là giới hạn của VBA)

Sử dụng hàm:
Hàm paNonIntersect nhận 1 đối số đầu tiên NonOfA để xác định xem chỉ lấy các đối tượng không giao nhau của Đối tượng Range đầu tiên hay không, còn lại là nhận nhiều hơn 1 Đối tượng Range

Dim Rng As Range
Set Rng = paNonIntersect(False , Range("A1:D10"), Range("B1:F10"), Range("A15:C100"), Range("N1:Z15")) ' , ....)

———————————————————————-
Ứng dụng:
1. FormatCondition không trùng với FormatCondition trước đó:
2. Tô màu không trùng với FormatCondition hoặc Vùng đã tô trước đó
… Và nhiều ứng dụng khác.

==================================================================

Sub test_NonIntersect()
  Dim R As Range, R1 As Range, R2 As Range
  Set R1 = Cells
  Set R2 = Range("A2:A10,B15:C1000")
  Dim ti#: ti = Timer
  Set R = NonIntersect(R1, R2)
  If Not R Is Nothing Then
    Debug.Print R.address(0, 0)
  End If
  Debug.Print Round(Timer - ti, 2)
End Sub

Sub test_paNonIntersect()
  Dim R As Range, R1 As Range, R2 As Range, R3 As Range
  Set R1 = Range("A1:B1")
  Set R2 = Range("B1:C1")
  Set R3 = Range("C1:D1")
  Dim ti#: ti = Timer
  Set R = paNonIntersect(False, R1, R2, R3)
  If Not R Is Nothing Then
    Debug.Print R.address(0, 0)
  End If
  Debug.Print Round(Timer - ti, 2)
End Sub

Function NonIntersect(RngA As Range, RngB As Range, _
                      Optional ByVal NonOfA As Boolean) As Range
  Dim Ri As Range, Ru As Range
  Dim P As Worksheet, Su, Si

If Not RngA.Parent Is RngB.Parent Then GoTo Ends
  Set P = RngA.Parent
  If NonOfA Then Set Ru = RngA Else Set Ru = UnionA(RngA, RngB)
  Set Ri = Intersect(RngA, RngB)
  If Ri Is Nothing Then Set NonIntersect = Ru: GoTo Ends
  Set Su = Ru.Areas: Set Si = Ri.Areas
  Dim cU As Range, cI As Range, t_R As Range, nF As Boolean
  Dim r1U&, r2U&, c1U%, c2U%
  Dim r1I&, r2I&, c1I%, c2I%

For Each cU In Su
    Set t_R = Nothing: nF = False
    For Each cI In Si
      If Not Intersect(cI, cU) Is Nothing Then
        If t_R Is Nothing Then
            r1U = cU.Row:    r2U = cU.Rows.Count + r1U - 1
            c1U = cU.Column: c2U = cU.Columns.Count + c1U - 1
            r1I = cI.Row:    r2I = cI.Rows.Count + r1I - 1
            c1I = cI.Column: c2I = cI.Columns.Count + c1I - 1
            With P
              If r1I - r1U > 0 Then Set t_R = UnionA(.Range(.Cells(r1U, c1U), .Cells(r1I - 1, c2U)), t_R)
              If r2U - r2I > 0 Then Set t_R = UnionA(.Range(.Cells(r2I + 1, c1U), .Cells(r2U, c2U)), t_R)
              If c1I - c1U > 0 Then Set t_R = UnionA(.Range(.Cells(r1U, c1U), .Cells(r2U, c1I - 1)), t_R)
              If c2U - c2I > 0 Then Set t_R = UnionA(.Range(.Cells(r1U, c2I + 1), .Cells(r2U, c2U)), t_R)
            End With
        Else
          Set t_R = NonIntersect(t_R, cI)
        End If
        nF = True
      End If
    Next cI
    If Not nF Then Set t_R = cU
    Set NonIntersect = UnionA(NonIntersect, t_R)
  Next cU
Ends:
  Set Ru = Nothing: Set Ri = Ru: Set t_R = Ru
  Set cU = Ru: Set Su = Ru
  Set cI = Ru: Set Si = Ru: Set P = Ru
End Function
Function paNonIntersect(NonOfA As Boolean, ParamArray Agrs()) As Range
  Dim C%, I%: C = UBound(Agrs)
  If C < 1 Then Exit Function
  Dim Total As Range, Agr1 As Range, Agr2 As Range
  Dim P As Worksheet
  For I = 0 To C
    If TypeName(Agrs(I)) = "Range" Then
      If Agr1 Is Nothing Then
        Set Agr1 = Agrs(I): Set P = Agr1.Parent
      Else
        Set Agr2 = Agrs(I)
        If P Is Agr2.Parent Then
          Set Agr1 = NonIntersect(Agr1, Agr2, NonOfA)
        End If
      End If
    End If
  Next
  Set paNonIntersect = Agr1
  Set P = Nothing: Set Agr1 = P: Set Agr2 = P
End Function

Function UnionA(RngA As Range, RngB As Range) As Range
  If RngA Is Nothing And Not RngB Is Nothing Then
    Set UnionA = RngB
  ElseIf RngB Is Nothing Then
    Set UnionA = RngA
  Else
    Set UnionA = Union(RngA, RngB)
  End If
End Function

Tag: Hàm NonIntersect, ngược lại với hàm Intersect, not intersect, Non-Intersect, not intersect vba, non-Intersect vba

[URL='www.giaiphapexcel.com/diendan/members/hesanbi.800675/']Liên hệ

Sub kkk()
    MsgBox NonIntersect(Range("A1:G14"), Range("C5:C8"), True).Address
End Sub
Mình dùng code đó như trên, kết quả rất là tốt, được kết quả là $D$1:$G$14,$A$1:$B$14,$A$9:$G$14,$A$1:$G$4. Hai vùng đầu kết quả rất là đúng, giờ mình muốn hàm đó trả lại kết quả là vùng D1:G14,A1:B14,C1:C4,C9:C14 thì phải làm sao?

@truongvu317
Thực ra tôi đã viết rất nhiều hàm Non-Intersect Nâng cao để trả ra các kiểu khác nhau như bên dưới.
Vì tôi đã viết nó cách đây khá lâu, nên bây giờ không nhớ là các Hàm đã hoàn thiện hay chưa. Tôi đã bỏ dỡ dự án này giữa chừng.

Và hàm trả về các mảng không có trùng với nhau cũng có như ảnh dưới.

Hình minh họa này trả về kiểu 5T1 của CubeStyle:
256212

'........................................
  ' A Parent of B
  '   1         2           2           3           4
  '1---+---+ +2--+---+ +3--+---+---+ +4--+---+ +5--------+
  '|   |\| | A |B| |   |\|   | |   +---+ |   +---+ |
  '| A |B| |   +---+ | A |B| A | | A |B| | A |B| |
  '|   |\| |       | |   |\|   | |   +---+ |   +---+ |
  '+---+---+ +---+---+ +---+---+---+ +---+---+ +---------+
  '
  ' A Meet B
  '     2             2-1          2-2            3-1
  '1---+---+---+ +2--+---+---+  3 '+---+---+ +4------+
  '|   |\|   | | A |\| B | +---+---+ B | |   +---+---+
  '| A |\| B | |   +---+---+ | A |\|   | | A |\| B |
  '|   |\|   | |       |     |   +---+---+ |   +---+---+
  '+---+---+---+ +-------+     +-------+     +-------+
  '........................................

' CubeStyle
            '0---------+  1---------+  2---------+  3---------+  4---------+  5T0-------+  5T1-------+  5T2-------+ ...
            '|         |  |  |   |  |  |      |  |  |  |      |  |  |   |  |  |         |  |         |  |         | ...
            '|--+---+--|  |  +---+  |  |--+---+  |  |  +---+--|  |--+---+--|  |--+---+--|  |--+---+--|  |--+---+--| ...
            '|  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  | ...
            '|--+---+--|  |  +---+  |  |  +---+--|  |--+---+  |  |--+---+--|  |  +---+  |  |  +---+--|  |--+---+  | ...
            '|         |  |  |   |  |  |  |      |  |      |  |  |  |   |  |  |  |   |  |  |  |      |  |      |  | ...
            '+---------+  +---------+  +---------+  +---------+  +---------+  +---------+  +---------+  +---------+ ...

@truongvu317
Bạn có thể tham khảo hàm NotIntersect bên dưới
Nhưng CubeStyle có thể chưa chính xác.
Vì hàm này tôi chưa kiểm thử đầy đủ để hoàn thiện nó.

Sub testNewNotIntersect()
   Debug.Print NotIntersect(Range("A1:G14"), Range("C5:C8"), True, 0).Address(0, 0)
   Debug.Print NotIntersect(Range("A1:G14"), Range("C5:C8"), True, 1).Address(0, 0)
   Debug.Print NotIntersect(Range("A1:G14"), Range("C5:C8"), True, 2).Address(0, 0)
   Debug.Print NotIntersect(Range("A1:G14"), Range("C5:C8"), True, 3).Address(0, 0)
   Debug.Print NotIntersect(Range("A1:G14"), Range("C5:C8"), True, 4).Address(0, 0)
End Sub

Function NotIntersect(ByVal RangeA As Range, _
                      ByVal RangeB As Range, _
             Optional ByVal optIsNonOnlyOfA As Boolean, _
             Optional ByVal CubeStyle As Long = 0) As Excel.Range
  '........................................
  ' A Parent of B
  '   1         2           2           3           4
  '1---+---+ +2--+---+ +3--+---+---+ +4--+---+ +5--------+
  '|   |\| | A |B| |   |\|   | |   +---+ |   +---+ |
  '| A |B| |   +---+ | A |B| A | | A |B| | A |B| |
  '|   |\| |       | |   |\|   | |   +---+ |   +---+ |
  '+---+---+ +---+---+ +---+---+---+ +---+---+ +---------+
  '
  ' A Meet B
  '     2             2-1          2-2            3-1
  '1---+---+---+ +2--+---+---+  3 '+---+---+ +4------+
  '|   |\|   | | A |\| B | +---+---+ B | |   +---+---+
  '| A |\| B | |   +---+---+ | A |\|   | | A |\| B |
  '|   |\|   | |       |     |   +---+---+ |   +---+---+
  '+---+---+---+ +-------+     +-------+     +-------+
  '........................................
  If RangeA Is Nothing And RangeB Is Nothing Then
    Exit Function
  ElseIf RangeB Is Nothing Then
    If Not optIsNonOnlyOfA Then Set NotIntersect = RangeB
    Exit Function
  ElseIf RangeA Is Nothing Then
    Set NotIntersect = RangeA: Exit Function
  End If
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  If Not RangeA.Parent Is RangeB.Parent Then
    Set NotIntersect = RangeA: Exit Function
  End If
  '........................................
  Dim WSheet                   As Excel.Worksheet
  Dim UR                       As Excel.Range
  Dim uArea                    As Excel.Range
  Dim iArea                    As Excel.Range
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  Dim TopU As Long, BotU As Long, TopI As Long, BotI As Long
  Dim LefU As Long, RigU As Long, LefI As Long, RigI As Long
  Dim FindIntersect             As Boolean, TotalRNG
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  Set WSheet = RangeA.Parent
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  If optIsNonOnlyOfA Then
    Set RangeB = Application.Intersect(RangeA, RangeB)
    If RangeB Is Nothing Then
      Set NotIntersect = RangeA: GoTo Ends
    End If
  Else
    Set RangeA = Application.Union(RangeA, RangeB)
    Set RangeB = Application.Intersect(RangeA, RangeB)
    If RangeB Is Nothing Then
      Set NotIntersect = Application.Union(RangeA, RangeB): GoTo Ends
    End If
  End If
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  Dim total$, R$, i%
  Dim iTop As Boolean, iLef As Boolean, iBot As Boolean, iRig As Boolean
  i = CubeStyle
  '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
  For Each uArea In RangeA.Areas
    FindIntersect = False: R = ""
    '........................................
    TopU = uArea.Row:    BotU = uArea.rows.Count + TopU - 1
    LefU = uArea.Column: RigU = uArea.Columns.Count + LefU - 1

'........................................

For Each iArea In RangeB.Areas
      If Not Application.Intersect(iArea, uArea) Is Nothing Then
        If R = "" Then
          '........................................
          TopI = iArea.Row:    BotI = iArea.rows.Count + TopI - 1
          LefI = iArea.Column: RigI = iArea.Columns.Count + LefI - 1

'........................................
          iTop = TopI - TopU > 0: iLef = LefI - LefU > 0
          iBot = BotU - BotI > 0: iRig = RigU - RigI > 0
          '---------------------
          With WSheet
            ' CubeStyle
            '0---------+  1---------+  2---------+  3---------+  4---------+  5T0-------+  5T1-------+  5T2-------+ ...
            '|         |  |  |   |  |  |      |  |  |  |      |  |  |   |  |  |         |  |         |  |         | ...
            '|--+---+--|  |  +---+  |  |--+---+  |  |  +---+--|  |--+---+--|  |--+---+--|  |--+---+--|  |--+---+--| ...
            '|  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  |  |  |\|  | ...
            '|--+---+--|  |  +---+  |  |  +---+--|  |--+---+  |  |--+---+--|  |  +---+  |  |  +---+--|  |--+---+  | ...
            '|         |  |  |   |  |  |  |      |  |      |  |  |  |   |  |  |  |   |  |  |  |      |  |      |  | ...
            '+---------+  +---------+  +---------+  +---------+  +---------+  +---------+  +---------+  +---------+ ...
            If iTop Then
              R = VBA.IIf(R = "", "", R & ",") & .Range(.Cells(TopU, VBA.IIf(iLef And (i = 1 Or i = 3 Or i = 4), LefI, LefU)), _
                .Cells(TopI - 1, VBA.IIf(iRig And (i = 1 Or i = 2 Or i = 4), RigI, RigU))).Address(0, 0)
              '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
              If i = 4 And iLef Then R = VBA.IIf(R = "", "", R & ",") & .Range(.Cells(TopU, LefU), .Cells(TopI - 1, LefI - 1)).Address(0, 0)
            End If
            If iLef Then
              R = VBA.IIf(R = "", "", R & ",") & .Range( _
                .Cells(VBA.IIf(iTop And (i = 0 Or i = 2 Or i = 4), TopI, TopU), LefU), _
                .Cells(VBA.IIf(iBot And (i = 1 Or i = 3 Or i = 4), BotI, BotU), LefI - 1)).Address(0, 0)
              '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
              If i = 4 And iBot Then R = VBA.IIf(R = "", "", R & ",") & .Range(.Cells(BotI + 1, LefU), .Cells(BotU, LefI - 1)).Address(0, 0)
            End If
            If iBot Then
              R = VBA.IIf(R = "", "", R & ",") & .Range( _
                .Cells(BotI + 1, VBA.IIf(iLef And (i = 1 Or i = 2 Or i = 4), LefI, LefU)), _
                .Cells(BotU, VBA.IIf(iRig And (i = 1 Or i = 3 Or i = 4), RigI, RigU))).Address(0, 0)
              '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
              If i = 4 And iRig Then R = VBA.IIf(R = "", "", R & ",") & .Range(.Cells(BotI + 1, RigI + 1), .Cells(BotU, RigU)).Address(0, 0)
            End If
            If iRig Then
              R = VBA.IIf(R = "", "", R & ",") & .Range( _
                .Cells(VBA.IIf(iTop And (i = 1 Or i = 3 Or i = 4), TopI, TopU), RigI + 1), _
                .Cells(VBA.IIf(iBot And (i = 0 Or i = 2 Or i = 4), BotI, BotU), RigU)).Address(0, 0)
              '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
              If i = 4 And iTop Then R = VBA.IIf(R = "", "", R & ",") & .Range(.Cells(TopU, RigI + 1), .Cells(TopI - 1, RigU)).Address(0, 0)
            End If
          End With
        Else
          Set UR = Application.Intersect(WSheet.Range(R), iArea)
          If Not UR Is Nothing Then
            Set UR = NotIntersect(WSheet.Range(R), UR, True, CubeStyle)
            If Not UR Is Nothing Then
              R = UR.Address(0, 0)
            Else
              R = VBA.vbNullString
            End If
          End If
        End If
        FindIntersect = True
      End If
    Next iArea
    If Not FindIntersect Then R = uArea.Address(0, 0)
    If R <> "" Then
      total = VBA.IIf(total = "", "", total & ",") & R
    End If
  Next uArea
  If total <> "" Then
    On Error GoTo Ends
    If UBound(Split(total, ",")) < 40 Then
      Set NotIntersect = WSheet.Range(total)
    Else
      VBA.Err.Raise 1110, , "Over Limit Range Areas (39)!"
    End If
  End If
Ends:
              Set uArea = Nothing
              Set iArea = Nothing
                 Set UR = Nothing
             Set WSheet = Nothing
End Function