Hướng dẫn lập trình VBA excel phần Intersect
Bạn đang xem bản rút gọn của tài liệu. Xem và tải ngay bản đầy đủ của tài liệu tại đây [86.28 KB, 4 trang ]
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]]
Sub
If Intersect[Target, Union[Rang, [D3], [D5]]] Is Nothing Then Exit
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