Hướng dẫn lập trình VBA excel phần Intersect

Bước đầu về phương thức Intersect ________________________________________ 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 dont 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 Private Sub Worksheet_Change(ByVal Target As Range) 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 End Sub 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: Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim MyName As Name On Error Resume Next If Range(MyRang) Is Nothing Then Exit Sub On Error GoTo 0

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

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

Private Sub Worksheet_Change(ByVal Target As Range)

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

End Sub

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:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

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

End Sub

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 ô

Private Sub Worksheet_Change(ByVal Target As Range)

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: End Sub

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

Code:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

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

End Sub

Đ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')):

Code:

Sub CopyRows()

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: End Sub

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

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

End Sub

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

Private Sub Worksheet_Change(ByVal Target As Range)

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

End Sub