4")
Chào Duy Longphamduylong đã viết:Có vấn đề này thấy đơn giản mà tìm hoài không ra đáp số.
Có 2 vùng: A=Range("A1:G20"), B=Range("C3
Làm sao xác định được vùng C=A-C (là vùng A mà loại bỏ các ô trong vùng B) bằng VBA ?
Mình có cách củ chuối, như sau:Có 2 vùng: A=Range("A1:G20"), B=Range("C3
Làm sao xác định được vùng C=A-B bằng VBA ?
Option Explicit[b]
Sub Range11()[/b]
Dim Rng As Range, RngA As Range, RngB As Range, RngC As Range
Set RngA = Range("A1:E16")
Set RngB = Range("B7:C10")
For Each Rng In RngA
If Intersect(Rng, RngB) Is Nothing Then
If RngC Is Nothing Then
Set RngC = Rng
Else
Set RngC = Union(RngC, Rng)
End If: End If
Next Rng
MsgBox RngC.Address[b]
End Sub[/b]
SA_DQ đã viết:
Function Union(Rng1 As Range, Rng2 As Range) As Range
If Rng1 Is Nothing Then
Set Union = Rng2
ElseIf Rng2 Is Nothing Then
Set Union = Rng1
Else
Set Union = Application.Union(Rng1, Rng2)
End If
End FunctionFunction SubtractFirstPrinciples(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next
If Application.Intersect(Rng1, Rng2).Address <> Rng2.Address Then _
Exit Function
On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
Dim Rslt As Range
If Application.Intersect(aCell, Rng2) Is Nothing Then
Set Rslt = Union(Rslt, aCell)
End If
Next aCell
Set SubtractFirstPrinciples = Rslt
End Function
Sub testSubtractFirstPrinciples()
Debug.Print SubtractFirstPrinciples( _
Sheets(1).Range("A1:f10"), _
Sheets(1).Range("A1,b2,c3,d4:e5,f6")).Address
End Sub
Sub AutoSelect()
On Error Resume Next
With Selection.SpecialCells(2)
Intersect(.EntireRow, .EntireColumn).Select
End With
End SubOption Explicit
Sub Seletor()
Dim Clls As Range
Dim rMax As Long, rMin As Long, cMax As Byte, cMin As Byte
With Selection
rMin = .Cells(1, 1).Row + .Rows.Count
cMin = .Cells(1, 1).Column + .Columns.Count
End With
For Each Clls In Selection
If Clls.Value = "GPE.COM" Then
If rMin > Clls.Row Then rMin = Clls.Row
If rMax < Clls.Row Then rMax = Clls.Row
If cMin > Clls.Column Then cMin = Clls.Column
If cMax < Clls.Column Then cMax = Clls.Column
End If
Next Clls
MsgBox Range(Cells(rMin, cMin), Cells(rMax, cMax)).Address
End Sub
Code này chưa đúng đâu nha! (Nhưng ý tưởng khá hay)
Không hiểu sau em chạy code của sư phụ cứ bị lổi hoài mà không tìm được nguyên nhân
Sub Selector()
Dim i As Long, Rng As Range
On Error Resume Next
If Selection.Count = 1 Then
Selection.Select
Else
With Selection.SpecialCells(2)
Set Rng = .Areas(1)
For i = 1 To .Areas.Count
Set Rng = Range(Rng, .Areas(i))
Next i
End With
Rng.Select
End If
End SubOption Explicit
Sub Seletor()
Dim Clls As Range, Rng As Range, sRng As Range
Dim MyAdd As String
Dim rMax As Long, rMin As Long, cMax As Byte, cMin As Byte
Set Rng = Selection
With Rng
rMin = .Cells(1, 1).Row + .Rows.Count
cMin = .Cells(1, 1).Column + .Columns.Count
End With
Set sRng = Rng.Find("GPE.COM", , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
With sRng
If rMin > .Row Then rMin = .Row
If rMax < .Row Then rMax = .Row
If cMin > .Column Then cMin = .Column
If cMax < .Column Then cMax = .Column
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Range(Cells(rMin, cMin), Cells(rMax, cMax)).Select
End SubVậy phải sửa code của sư phụ lại thành vầy chăng:
Sub Seletor()
Dim Clls As Range, Rng As Range, sRng As Range
Dim MyAdd As String
Dim rMax As Long, rMin As Long, cMax As Byte, cMin As Byte
Set Rng = Selection
With Rng
rMin = .Cells(1, 1).Row + .Rows.Count
cMin = .Cells(1, 1).Column + .Columns.Count
End With
Set sRng = Rng.Find("*", , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
With sRng
If rMin > .Row Then rMin = .Row
If rMax < .Row Then rMax = .Row
If cMin > .Column Then cMin = .Column
If cMax < .Column Then cMax = .Column
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Range(Cells(rMin, cMin), Cells(rMax, cMax)).Select
End Sub
Thì thầy thêm cái Selection.Special(3) vào nữa
Sub Selector()
Dim i As Long, Rng As Range, ValRng As Range, ForRng As Range
On Error Resume Next
If Selection.Count = 1 Then
Selection.Select
Else
Set ValRng = Selection.SpecialCells(2)
Set ForRng = Selection.SpecialCells(3)
If ForRng Is Nothing Then Set ForRng = ValRng
If ValRng Is Nothing Then Set ValRng = ForRng
With Union(ValRng, ForRng)
Set Rng = .Areas(1)
For i = 1 To .Areas.Count
Set Rng = Range(Rng, .Areas(i))
Next i
End With
Rng.Select
End If
End SubDạ! Em hiểu ý của anh... nhưng vì em đọc câu hỏi của thầy Long, thấy có đoạn:
Chổ màu đỏ ấy sư phụ
Test đã đúng ý đồ. Cám ơn tất cả các bạn.
Nếu vậy thì vùng chọn này vẫn.. thừa thầy à (nếu trong vùng có cell rổng)
Ý em rất hay. Nhưng mỗi trường hợp sẽ có 1 cách làm riêng. Quan trọng là mình biết phương pháp làm. Đúng là cộng đổng GPE giúp cho mình sáng mắt ra.
Sub CheckRange()
Dim RngChk As String, Rng1 As String, Rng2 As String
Dim rMax As Long, rMin As Long, cMax As Long, cMin As Long, nTmp As Long
Dim vt1 As Long, vt2 As Long, ten As String, kytu As String
On Error Resume Next
Rng1 = Selection.SpecialCells(xlCellTypeConstants, 23).Address(, , xlR1C1)
Rng2 = Selection.SpecialCells(xlCellTypeFormulas, 23).Address(, , xlR1C1)
RngChk = Rng1 & "," & Rng2 & "Z"
rMin = Cells.Rows.Count
cMin = Cells.Columns.Count
vt1 = 1
Do
ten = Mid(RngChk, vt1, 1)
If ten = "R" Or ten = "C" Then
vt1 = vt1 + 1
vt2 = vt1
Do
kytu = Mid(RngChk, vt2, 1)
If IsNumeric(kytu) = False Then
' Stop
nTmp = Mid(RngChk, vt1, vt2 - vt1)
If nTmp > rMax And ten = "R" Then rMax = nTmp
If nTmp < rMin And ten = "R" Then rMin = nTmp
If nTmp > cMax And ten = "C" Then cMax = nTmp
If nTmp < cMin And ten = "C" Then cMin = nTmp
vt1 = vt2
Exit Do
Else
vt2 = vt2 + 1
End If
Loop
Else
vt1 = vt1 + 1
End If
Loop While vt1 < Len(RngChk)
MsgBox "rMin=" & rMin & " rMax=" & rMax & " cMin=" & cMin & " cMax=" & cMax
End Sub
