Bước đầu về phương thức Intersect

[SA_DQ]

Trong cửa sổ VBA ta gỏ Intersect , quét chọn toàn bộ và nhấn {F1} ta sẽ nhận được phần trợ giúp về phương thức Intersect như sau:

Intersect Method
Returns a Range object that represents the rectangular intersection of two or more ranges.
expression.Intersect(Arg1, Arg2, ...)
expression Optional. An expression that returns an Application object.
Arg1, Arg2, ... Required Range. The intersecting ranges. At least two Range objects must be specified.
Example
This example selects the intersection of two named ranges, rg1 and rg2, on Sheet1. If the ranges don't intersect, the example displays a message.
Worksheets("Sheet1").Activate
Set isect = Application.Intersect(Range("rg1"), Range("rg2"))
If isect Is Nothing Then
MsgBox "Ranges do not intersect"
Else
isect.Select
End If

Tiếp tục ta xem thêm một số ví dự sau:
1./ Ví dụ khi thay đổi trị của một ô trong vùng

[b]Private Sub Worksheet_Change(ByVal Target As Range)[/b]
    StrC = "The active cell does "
    If Intersect(ActiveCell, Range("A1:A9")) Is Nothing Then
        MsgBox StrC & "NOT Intersect A1:A9", , Target.Address
    Else
        MsgBox StrC & "Intersect A1:A9", , Target.Address    
    End If

    If Not Intersect(Target, Range("A2,B1:B9,C4:D9")) Is Nothing Then
        MsgBox "Hello", , "A2,B1:B10,C5:D9"
    ElseIf Not Intersect(Range(“A1:D9”,Target) Is Nothing then
	 MsgBox "A1:D9" ,, "Hello!"	
         	
    End If

[b]End Sub[/b]

2./ Liên quan đến vùng được đặt tên:

Nếu ta đã đặt tên cho vùng nào đó trong bảng tính là "MyRang" thì khi ta đụng đến 1 ô trong vùng đó, sẽ nhận được thông báo:

[b]Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/b]
 Dim MyName As Name       
    On Error Resume Next
    If Range("MyRang") Is Nothing Then Exit Sub
    On Error GoTo 0
    If Not Intersect(Target, Range("MyRang")) Is Nothing Then
        MsgBox Range("MyRang").Name, , "Hello"
    End If

[b]End Sub[/b]

3./ Tô màu nền của vùng được nhập các số ngẫu nhiên

Khi ta chọn vùng từ A7 đến A35, sau đó nhập vô thanh công thức chuỗi: =INT(19*RAND())+32. Chúng ta kết thúc bằng tổ hợp CTRL+ENTER thì đoạn mã sau sẽ tô màu nền theo trị trong ô

[b]Private Sub Worksheet_Change(ByVal Target As Range)[/b]
  Dim rgArea As Range, rgCell As Range
  Dim iColor As Integer
     ' Get the intersect of the target & the proper range
    Set Target = Intersect(Target, Range("A6:A62"))
    If (Not Target Is Nothing) Then      
      For Each rgArea In Target.Areas     
       For Each rgCell In rgArea.Cells    
         With rgCell                                                      
           If .Value < 56 Then .Interior.ColorIndex = .Value
         End With
       Next rgCell, rgArea
    End If
 Exit Sub:[b] End Sub[/b]

4./ Phương thức Union() song hành:

[b]Private Sub Worksheet_Change(ByVal Target As Excel.Range)[/b]
 Dim Rang As Range
    Set Rang = Union([A1], [A3], [A5], [A7], [A9], [B1], [B3], [B5], [B7], [B9], [C1], [C3], [C5], [C7], [C9])
    Set Rang = Union(Rang, [E2], [E4], [E6], [E8], [F2], [F4], [F6], [F8], [G2], [G4], [G6], [G8], [H2])
    
    If Intersect(Target, Union(Rang, [D3], [D5])) Is Nothing Then Exit Sub
    If Not Intersect(Target, Rang) Is Nothing Then
        With Target.Offset(0, 1)
            .Value = .Value + Target
        End With
    ElseIf Not Intersect(Target, [D4]) Is Nothing Then
        With Range("E4")
            .Value = .Value + [D4]
        End With
    Else
        With Range("E5")
            .Value = .Value + [D5]
        End With
    End If
[b]End Sub[/b]

Đoạn code sau cho phép ta chép các hàng intersect với vùng là một số ô trong 1 cột, mà các hàng này có ô trong cột chọn không chứa giá tri:
(Cụ thể: ta chọn vùng từ 'J3:J9' mà trong đó giá trị tại J5 & J8 = ""; thí khi chạy macro chúng ta sẽ có hai dòng dữ liệu 5 & 8 bên sheets('S2')):

[b] Sub CopyRows() [/b]
    Dim UniRange As Range, Rng As Range
    For Each Rng In Selection
        With Rng
            If .Value = "" And .Offset(0, 1).Value <> "" Then
                If UniRange Is Nothing Then
                    Set UniRange = .EntireRow
                Else
                    Set UniRange = Application.Union(UniRange, .EntireRow)
            End If:            End If
        End With
    Next Rng                '    MsgBox UniRange.Address
    UniRange.Copy Destination:=Sheets("S2").Range("A65536").End(xlUp).Offset(1, 0)
 Exit Sub:             [b]  End Sub [/b]

5./ Một cách khác để biến các chuỗi nhập vô cột ‘D’ đều viết hoa.

[b]Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/b]
 Dim Rang As Range:             Dim StrC As String
    Set Rang = Union([A1], [A3], [A5], [A7], [A9], [B1], [B3], [B5], [B7], [B9], [C1], [C3], [C5], [C7], [C9])
    Set Rang = Union(Rang, [E2], [E4], [E6], [E8], [F2], [F4], [F6], [F8], [G2], [G4], [G6], [G8], [H2], [H4])

   StrC2 = "D1:D999"		‘ !!!	***	!!!
  
    If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Union(Rang, [h6], [h8], [i2], [i4], [i6], [i8])) Is Nothing Then
     
        Target.Value = UCase(Left(Target.Value, 1)) & Mid(Target.Value, 2)
    ElseIf Not Intersect(Target, Range(StrC2)) Is Nothing Then
        Target.Value = UCase(Target.Value)
    End If
    Application.EnableEvents = True
    On Error GoTo 0

[b]End Sub[/b]

6./ Một cách nhập tự động ngày hiện hành vô trường [NgThang] của CSDL

Nếu ta có CSDL mà cột B chứa [MaHg] & cột C chứa ngày nhập, cột F chứa ngày xuất thì đoạn mã sau sẽ cho phép tự động nhập ngày hiện hành khi ta nhập vô cột trước nó là mã vật tư, hàng hoá nhập hay xuất.

[b]Private Sub Worksheet_Change(ByVal Target As Range)[/b]

   If Not Intersect(Target, Range("B:B,E:E")) Is Nothing Then
      If Not IsEmpty(Target) Then
        Target.Offset(0, 1).Value = Date
    Else
       Target.Offset(0, 1).Value = Empty
    End If
  End If
 [b]End Sub[/b]

 

[SA_DQ]

(Tiếp theo)

7./ Phương thức Intersect và copy vùng dữ liệu

Dùng phương thức Intersect để kiểm tra vùng dữ liệu khi cần copy
Trường hợp A:

[b]Sub ShtChange()[/b]
 Dim Rang0 As Range, IntersectRng As Range
     
     Sheets("S4").Select:               Set Rang0 = Range("J3:J16")
    Set IntersectRng = Intersect(Selection, Rang0)
    If IntersectRng Is Nothing Then Exit Sub
    CopyC IntersectRng     
[b]End Sub[/b]

[b]Private Sub CopyC(Target As Range)[/b]
    Dim lRow As Long
     
    Application.ScreenUpdating = False:     Application.EnableEvents = 0
     lRow = Target.Row      '    lRow = IntersectRng.Row
    'Xoá 1 dòng chứa dữ liệu
    Range("A" & lRow & ":J" & lRow).ClearContents
    Range("A" & lRow + 1 & ":I16").Copy  '& Copy Các dòng dưới lên thay chỗ
    Range("A" & lRow & ":I15").PasteSpecial xlPasteValues
    Range("A16:I16").ClearContents
     
    Application.EnableEvents = True:       Application.ScreenUpdating = -1
     
[b]End Sub[/b]

Trường hợp B

[b]Sub CopyCol()[/b]
 Dim iRow As Integer
    iRow = ActiveCell.Row
    If Not Intersect(ActiveCell, Range("$C$3:$M$3000")) Is Nothing Then
        Application.EnableEvents = False
        If Range("B" & iRow) = "" Then
            Range("O" & iRow) = "P"
        Else
            Range("B" & iRow).Select
            Selection.Copy
            Range("Q7").Select
            If Not Range("Q7") = "" Then
                Range("Q6:Q150").Select
                Selection.End(xlDown).Offset(1, 0).Select
                 'Selection.Offset(1, 0).Select
            End If
            Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            Range("B" & iRow) = "":               Range("O" & iRow) = "P"
        End If
    Else
        Range("O" & iRow).Interior.ColorIndex = xlColorIndexNone
    End If
    Application.EnableEvents = True[b]     
End Sub[/b]

Trường hợp C

[b]Sub Copy_Stuff()[/b]
   On Error GoTo ExitSub
     
Dim rCols As Range, CheckCells As Range, rCell As Range, CopyRange As Range
    
    Dim bDem As Long
     
    Set rCols = Sheet1.Range("A:I, L:R")
    Set CheckCells = Intersect(Sheet1.Range("L9:L65536"), Sheet1.UsedRange)
    
    For Each rCell In CheckCells
        If rCell.Value > 0 Then
            bDem = bDem + 1
            If bDem = 1 Then
                Set CopyRange = rCell.EntireRow
            Else
                Set CopyRange = Union(CopyRange, rCell.EntireRow)
            End If
        End If
    Next rCell
    
    Set CopyRange = Intersect(rCols, CopyRange)
     
    For Each rCell In CopyRange.Areas
        bDem = Sheet3.Rows.Count
        Set rCols = Sheet2.Cells(bDem, rCell.Column).End(xlUp).Offset(1, 0)
        rCell.Copy rCols
    Next rCell
ExitSub:     [b]  End Sub[/b]

Trường hợp D

[b]Sub Get_Data()[/b]
On Error Resume Next
    Dim vRange As Range, MatchCells As Range, cell As Range
    Dim NgDau As Date, NgCuoi As Date
    Sheets("S2").Select
    NgDau = #9/16/2006#:                        NgCuoi = 9 + NgDau
    Set vRange = Range("D:D", "F:F")
    For Each cell In vRange.SpecialCells(xlConstants, xlNumbers)
        If cell.Value >= NgDau And cell.Value <= NgCuoi Then
            If MatchCells Is Nothing Then
                Set MatchCells = cell.EntireRow
            Else
               Set MatchCells = Union(MatchCells, cell.EntireRow)
            End If
        End If
    Next cell
    Intersect(MatchCells, vRange).Copy
   Sheets("S3").Range("G2").PasteSpecial (xlValues)
   Application.CutCopyMode = False:             Sheet2.Select
    MsgBox Intersect(MatchCells, vRange).Address, , MatchCells.Address

   Selection.Offset(0, 1).SpecialCells(xlConstants, xlTextValues).ClearContents
     
[b]End Sub[/b]

Trường hợp E

[b]Sub GenerateSht()[/b]
 'The following will generate the Over/Under worksheet
 'Range copied will depend on whether or not the value in column 11 is greater than 0
 'Columns 9 and 10 are not to be copied.
Dim Cols As Range, SearchCell As Range, CopyRange As Range
Dim wSheet As Object, LastRow As Long, lDem As Long
 
With Application
    .ScreenUpdating = False:        .Calculation = xlCalculationManual
End With
Set wSheet = Sheets("DNgh"):        wSheet.Range("A9:T999").ClearContents
Sheets("S4").Select
Set Cols = Range("A:I, L:S"):          Set SearchCell = Range("B9")
Set wSheet = Sheets("S4")
With wSheet
    Do While Len(SearchCell) > 1 'Bat Dau Tu B9 den khi Len(B(i)) > 1
        If SearchCell.Offset(0, 10) <> 0 Then
            lDem = lDem + 1
            If lDem = 1 Then
                Set CopyRange = SearchCell.EntireRow
            Else
                Set CopyRange = Union(CopyRange, SearchCell.EntireRow)
            End If
        End If
        Set SearchCell = SearchCell.Offset(1, 0) 'Set SearchCell Variable for next loop
    Loop
End With

Set CopyRange = Intersect(Cols, CopyRange)
Set wSheet = Sheets("DNgh")                     'Release
For Each SearchCell In CopyRange.Areas 
'insert the copied values on the DNgh sheet
    lDem = wSheet.Rows.Count
    Set Cols = wSheet.Cells(lDem, SearchCell.Column).End(xlUp).Offset(1, 0)
        
    SearchCell.Copy:                       Cols.PasteSpecial (xlValues)
Next SearchCell

With wSheet 'Inserts the underscore in the empty cells J & K of the DNgh sheet
    LastRow = .Range("B" & Rows.Count).End(xlUp).Row 'Set variable to the specified range
     
    .Range("B9:B" & LastRow).Offset(0, 8).Resize(, 2) = "_________"
End With
Set wSheet = Nothing                      'Release the variable from memory
With Application
    .ScreenUpdating = True:                     .Calculation = xlCalculationAutomatic
End With
[b]End Sub [/b]'END GenerateSht