Bỏ chọn ô hay 1 vùng nhỏ trong 1 vùng lớn đã chọn

[SA_DQ]

http://giaiphapexcel.com/forum/showthread.php?t=8226 #2
Thấy cái này hơi hay, nên làm thử;
Kết quả như sau:

Option Explicit
Sub DeSelect()
 Dim SAddress As String
 Dim lRng As Range, dRng As Range
 Dim Clls As Range, SRng As Range
 
 Set lRng = Selection
 SAddress = InputBox("HAY NHAP VUNG BO CHON:")
 Set dRng = Range(SAddress)
 For Each Clls In lRng
    If Intersect(Clls, dRng) Is Nothing Then
        If SRng Is Nothing Then
            Set SRng = Clls
        Else
            Set SRng = Union(Clls, SRng)
        End If
    End If
 Next Clls
 SRng.Select
End Sub

 

[Nguyễn Duy Tuân]

DeSelect

Dựa theo code của anh SA_DQ, em sửa lại một chút thế này.

Sub DeSelect()
 
 Dim lRng As Range, dRng As Range
 Dim Clls As Range, SRng As Range
 
 Set lRng = Selection
 
 On Error Resume Next
 Set dRng = ActiveCell
[COLOR="Red"] Set dRng = Application.InputBox("HAY NHAP VUNG BO CHON" + Chr(13) + _
                                "Ket hop Chuot cung cac phim CTRL, SHIFT de nhan dia chi", "DeSelection", Default:=dRng.Address, Type:=8)
[/COLOR]  
 For Each Clls In lRng
    If Intersect(Clls, dRng) Is Nothing Then
        If SRng Is Nothing Then
            Set SRng = Clls
        Else
            Set SRng = Union(Clls, SRng)
        End If
    End If
 Next Clls
 
[COLOR="Red"] If Not SRng Is Nothing Then
    SRng.Select
 End If
[/COLOR] 
End Sub

 

[SA_DQ]

ASAP Utilities - Mở rọng vùng chọn cho tới dòng cuối

http://giaiphapexcel.com/forum/showthread.php?t=8226#9
Phát huy chiến quả, xin giới thiệu cách mở rọng vùng đã chọn tới dòng cuối của các cột chứa dữ liệu đã chọn;
Nhờ Tuân, BAP & các bạn khác góp thêm ý kiến

Option Explicit

Sub SelectExpandSelectionToLastUsedRow()
 Dim lRow As Long, Rng As Range 
 
 If WorksheetFunction.CountA(Cells) > 0 Then
    Set Rng = Selection
    lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    Set Rng = Rng.Resize(lRow, Rng.Columns.Count)
           
    lRow = Rng.Find(What:="*", After:=Rng.Cells(1, 1), SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    Rng.Resize(lRow - Rng.Cells(1, 1).Row + 1, Rng.Columns.Count).Select
 End If

End Sub

 

[Nguyễn Duy Tuân]

"SelectExpandSelectionToLastUsedRow" - Chức năng tuy đơn giản nhưng thuật giải của anh hay lắm!

 

[Mr Okebab]

Bác dùng resize rất hay.

Cái quan trọng là giải thuật, chứ có quan trọng gì mấy dòng code.

Bội phục bội phục!

Cảm ơn bác nhé!

 

[SA_DQ]

Cảm ơn các bạn quá khen!

Nhưng góp ý lại không (?!)
Chưa bẫy lỗi hay bẫy chưa hết lỗi mà. . . . (!)

Nhờ các MOD/SMOD xóa giúp bài này sau 10hAM - Xin cảm ơn!​

 

[phamduylong]

To SA_DQ, TuanVNUNI: hàm loại bỏ vùng chọn rất hay, nhưng các bạn có thử khi vùng chọn ban đầu lớn hay chưa? Tôi chọn hết bảng tính thì chỉ không thể chờ cho kết thúc. Không biết có cách nào lảm nhanh hơn không?

 

[SA_DQ]

To SA_DQ, TuanVNUNI: hàm loại bỏ vùng chọn khi thử với vùng chọn ban đầu lớn hay chọn hết bảng tính thì chỉ không thể chờ cho kết thúc. Có cách nào lảm nhanh hơn không?

Được rồi này bạn Duy Long à!
Giải quyết chỉ trong tíc tắt, do Code hơi dài!!

Sub SelectNoDeselectCells()
 Dim LRng As Range, DRng As Range, SRng
 Dim LDgD As Long, LDgC As Long
 Dim DDgD As Long, DDgC As Long
 Dim LCTr As Integer, LCF As Integer
 Dim DCTr As Integer, DCF As Integer
 
 Set LRng = Selection
 LDgD = LRng.Cells(1, 1).Row
 LDgC = LDgD + LRng.Rows.Count - 1
 LCTr = LRng.Cells(1, 1).Column
 LCF = LCTr + LRng.Columns.Count - 1
 
 Set DRng = Range(InputBox("Hay Chon Dia Chi Bo Chon:"))
 DDgD = DRng.Cells(1, 1).Row
 DDgC = DDgD + DRng.Rows.Count - 1
 DCTr = DRng.Cells(1, 1).Column
 DCF = DCTr + DRng.Columns.Count - 1
  
 If DDgD < LDgD Or DDgC > LDgC Or _
    DCTr < LCTr Or DCF > LCF Then
    MsgBox "Dien Khong Vay?", , "GPE":      Exit Sub
    
1 ElseIf DDgD = LDgD And DCF < LCF And DDgC < LDgC _
    And DCTr = LCTr Then
    DDgD = LDgD + DRng.Rows.Count
    Union(Range(Cells(LDgD, DCF + 1), Cells(LDgC, LCF)), _
        Range(Cells(DDgD, LCTr), Cells(LDgC, LCF))).Select
        
2 ElseIf DDgD = LDgD And DCTr > LCTr And _
    DCF < LCF And DDgC < LDgC Then
    Set SRng = Union(Range(Cells(LDgD, LCTr), Cells(LDgC, DCTr - 1)), _
        Range(Cells(LDgD, DCF + 1), Cells(LDgC, LCF)))
    Union(SRng, Range(Cells(DDgC + 1, DCTr), _
        Cells(LDgC, DCF))).Select
3 ElseIf DDgD = LDgD And DCF = LCF And DDgC < LDgC _
    And DCTr > LCTr Then
    DDgD = LDgD + DRng.Rows.Count
    Union(Range(Cells(LDgD, LCTr), Cells(LDgC, DCTr - 1)), _
        Range(Cells(DDgD, DCTr), Cells(LDgC, LCF))).Select
4 ElseIf DDgD = LDgD And DCF = LCF And DDgC < LDgC _
    And DCTr = LCTr Then
    DDgD = LDgD + DRng.Rows.Count
    Range(Cells(DDgD, LCTr), Cells(LDgC, LCF)).Select
5 ElseIf DDgD = LDgD And DCF < LCF And DDgC = LDgC _
    And DCTr = LCTr Then
    Range(Cells(LDgD, DCF + 1), Cells(LDgC, LCF)).Select
6 ElseIf DDgD = LDgD And DCF < LCF And DDgC = LDgC _
    And DCTr > LCTr Then
    Union(Range(Cells(LDgD, LCTr), Cells(LDgC, DCTr - 1)), _
        Range(Cells(LDgD, DCF + 1), Cells(LDgC, LCF))).Select
7 ElseIf DDgD = LDgD And DCF = LCF And DDgC = LDgC _
    And DCTr > LCTr Then
    Range(Cells(LDgD, LCTr), Cells(LDgC, DCTr - 1)).Select
8 ElseIf DDgD = LDgD And DDgC = LDgC And _
    DCTr = LCTr And DCF = LCF Then
    MsgBox "No More Select", , "GPE"
9 ElseIf DDgD > LDgD And DCF < LCF And DDgC < LDgC _
    And DCTr = LCTr Then
    Set SRng = Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
        , Range(Cells(DDgC + 1, LCTr), Cells(LDgC, LCF)))
    Union(SRng, Range(Cells(DDgD, DCF + 1), Cells(DDgC, LCF))).Select
10 ElseIf DDgD > LDgD And DDgC < LDgC And _
    DCTr > LCTr And DCF < LCF Then
    Set SRng = Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgC + 1, LCTr), Cells(LDgC, LCF)))
    Union(SRng, Range(Cells(DDgD, LCTr), Cells(DDgC, DCTr - 1)) _
    , Range(Cells(DDgD, DCF + 1), Cells(DDgC, LCF))).Select
11 ElseIf DDgD > LDgD And DDgC < LDgC And _
    DCTr > LCTr And DCF = LCF Then
    Set SRng = Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgC + 1, LCTr), Cells(LDgC, LCF)))
    Union(SRng, Range(Cells(DDgD, LCTr), Cells(DDgC, DCTr - 1))).Select
12 ElseIf DDgD > LDgD And DDgC < LDgC And _
    DCTr = LCTr And DCF = LCF Then
    Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgC + 1, LCTr), Cells(LDgC, LCF))).Select
13 ElseIf DDgD > LDgD And DDgC = LDgC And _
    DCTr = LCTr And DCF < LCF Then
    Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgD, DCF + 1), Cells(LDgC, LCF))).Select
14 ElseIf DDgD > LDgD And DDgC = LDgC And _
    DCTr > LCTr And DCF < LCF Then
    Set SRng = Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgD, LCTr), Cells(LDgC, DCTr - 1)))
    Union(SRng, Range(Cells(DDgD, DCF + 1), Cells(LDgC, LCF))).Select
15 ElseIf DDgD > LDgD And DDgC = LDgC And _
    DCTr > LCTr And DCF = LCF Then
    Union(Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)) _
    , Range(Cells(DDgD, LCTr), Cells(LDgC, DCTr - 1))).Select
16 ElseIf DDgD > LDgD And DDgC = LDgC And _
    DCTr = LCTr And DCF = LCF Then
    Range(Cells(LDgD, LCTr), Cells(DDgD - 1, LCF)).Select
    
 End If
 Set LRng = Nothing:                                Set DRng = Nothing
 
End Sub

 

[Nguyễn Duy Tuân]

Oh, chạy quá nhanh anh ạ! Nhưng nó chỉ đúng khi người dùng chỉ "Deselect" một vùng thôi.

Em dùng kiểu khai báo dưới đây.

Set dRng = Application.InputBox("HAY NHAP VUNG BO CHON" + Chr(13) + _
"Ket hop Chuot cung cac phim CTRL, SHIFT de nhan dia chi", "DeSelection", Default:=dRng.Address, Type:=8)

Kết hợp phím CTRL, em "Deselect" nhiều vùng không liên tiếp (Vídụ: RANGE(A1:C4,C6:C10,E2:F8) ) chạy thì nó chỉ bỏ chọn môĩ A1:C4 thôi.

Bác kiểm tra lại và tìm cách nhé. Chúc bác khoẻ!

 

[SA_DQ]

SelectExpandSelectionToLastUsedRow

Nhưng nó chỉ đúng khi người dùng chỉ "Deselect" một vùng thôi.
Em dùng kiểu khai báo "Deselect" nhiều vùng không liên tiếp
(Vídụ: RANGE(A1:C4,C6:C10,E2:F8) ) chạy thì nó chỉ bỏ chọn môĩ A1:C4 thôi. Bác kiểm tra lại và tìm cách nhé!

Mình giải quyết được trường hợp này (chọn vùng không liên tục).
Nhưng chỉ ờ macro sau (Vì nó đơn giản hơn): SelectExpandSelectionToLastUsedRow
Mới là kết quả ban đầu, nhưng cứ đưa lên, những chỉ mong các bạn góp thêm ý; Xin cảm ơn nhiều!

Option Explicit

Sub SelectExpandSelectionToLastUsedRow()
 Dim lRow As Long, Rng As Range
  
 If WorksheetFunction.CountA(Cells) > 0 Then
   Set Rng = Application.InputBox(prompt:="Select a DeSelectCells", Type:=8)
   Set Rng = AllRange(Rng)    '<==='
    lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    Set Rng = Rng.Resize(lRow, Rng.Columns.Count)
            
    lRow = Rng.Find(What:="*", After:=Rng.Cells(1, 1), SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    Rng.Resize(lRow - Rng.Cells(1, 1).Row + 1, Rng.Columns.Count).Select
 End If

End Sub

[B]Function AllRange(Rng As Range) As Range[/B]
 Dim Clls As Range
 Dim TRow As Long, BRow As Long
 Dim LCol As Integer, RCol As Integer
 LCol = 255:        RCol = 1 '
 TRow = 65432:      BRow = 1 '
 For Each Clls In Rng
    If Clls.Column < LCol Then LCol = Clls.Column
    If Clls.Column > RCol Then RCol = Clls.Column
    If Clls.Row < TRow Then TRow = Clls.Row
    If Clls.Row > BRow Then BRow = Clls.Row
 Next Clls
 Set AllRange = Range(Cells(TRow, LCol), Cells(BRow, RCol))
[B]End Function [/B]

 

[phamduylong]

Được rồi này bạn Duy Long à!

Chạy rất nhanh. Nhưng nếu chọn vùng loại có một số ô nằm ngoài vùng chọn (ví dụ chọn B5:F22, loại D2:H14) chưa được. Đúng ra vùng còn lại là B5:C22 và D15:F22.
Sub LoaiVung cho phép vùng loại nằm trong, hoặc có một phần trong vùng chọn.

Sub LoaiVung()
On Error GoTo baoloi
Dim v_loai As Range, v_chon As Range, isect As Range
Dim vung As Range, loai As Range
Dim ten_chon As String
Dim rowchon_tren As Double, rowchon_duoi As Double, colchon_phai As Integer, colchon_trai As Integer
Dim rowloai_tren As Double, rowloai_duoi As Double, colloai_phai As Integer, colloai_trai As Integer
Dim ten_loai As String

Set v_chon = Selection
ten_chon = v_chon.Address(, , xlR1C1)
Cells(1, 1) = ten_chon
rowchon_tren = Selection.Row
colchon_trai = Selection.Column
rowchon_duoi = Val(Mid(ten_chon, InStr(1, ten_chon, ":R") + 2))
If rowchon_duoi = 0 Then rowchon_duoi = rowchon_duoi = Cells.Rows.Count

colchon_phai = Val(Mid(ten_chon, InStr(InStr(1, ten_chon, ":"), ten_chon, "C") + 1))
If colchon_phai = 0 Then colchon_phai = Cells.Columns.Count
ten_loai = InputBox("Vùng dang chon: " & v_chon.Address(0, 0) & Chr(13) & _
______"Nhap cac o loai khoi vung chon:")
Set v_loai = Range(ten_loai)
ten_loai = v_loai.Address(, , xlR1C1)
Set isect = Application.Intersect(v_chon, v_loai)
If isect Is Nothing Then GoTo baoloi
rowloai_tren = v_loai.Row
If rowloai_tren < rowchon_tren Then rowloai_tren = rowchon_tren
colloai_trai = v_loai.Column
If colloai_trai < colchon_trai Then colloai_trai = colchon_trai
rowloai_duoi = Val(Mid(ten_loai, InStr(1, ten_loai, ":R") + 2))
If rowloai_duoi = 0 Or rowloai_duoi > rowchon_duoi Then rowloai_duoi = rowchon_duoi
colloai_phai = Val(Mid(ten_loai, InStr(InStr(1, ten_loai, ":"), ten_loai, "C") + 1))
If colloai_phai = 0 Or colloai_phai > colchon_phai Then colloai_phai = colchon_phai
If colchon_trai < colloai_trai Then
__Set vung = Range(Cells(rowchon_tren, colchon_trai), Cells(rowchon_duoi, colloai_trai - 1))
__vung.Select
__Set loai = vung
End If
If colchon_phai > colloai_phai Then
__Set vung = Range(Cells(rowchon_tren, colloai_phai + 1), Cells(rowchon_duoi, colchon_phai))
__vung.Select
__If loai Is Nothing Then
____Set loai = vung
__Else
____Set loai = Application.Union(loai, vung)
__End If
End If
If rowchon_tren < rowloai_tren Then
__Set vung = Range(Cells(rowchon_tren, colloai_trai), Cells(rowloai_tren - 1, colloai_phai))
__vung.Select
__If loai Is Nothing Then
____Set loai = vung
__Else
____Set loai = Application.Union(loai, vung)
__End If
End If
If rowchon_duoi > rowloai_duoi Then
__Set vung = Range(Cells(rowloai_duoi + 1, colloai_trai), Cells(rowchon_duoi, colloai_phai))
__vung.Select
__If loai Is Nothing Then
____Set loai = vung
__Else
____Set loai = Application.Union(loai, vung)
__End If
End If
If loai Is Nothing Then
__GoTo baoloi
Else
__loai.Select
End If
Exit Sub
baoloi:
If Err.Number = 1004 Then
__MsgBox "Ban nhap dia chi vung loai [ " & ten_loai & " ] sai!"
ElseIf isect Is Nothing Then
__MsgBox "Vung loai [ " & v_loai.Address(0, 0) & " ] ngoai vung chon [ " & v_chon.Address(0, 0) & " ]" & Chr(13) & _
__"Không loai duoc !"
Else
__MsgBox "Vung loai [ " & v_loai.Address(0, 0) & " ] lon hon vung chon [ " & v_chon.Address(0, 0) & " ]" & Chr(13) & _
__"Không loai duoc !"
End If
End Sub

 

[SA_DQ]

. . . nhanh. Nhưng nếu chọn vùng loại có một số ô nằm ngoài vùng chọn (ví dụ chọn B5:F22, loại D2:H14) chưa được. Đúng ra vùng còn lại là B5:C22 và D15:F22.
Sub LoaiVung cho phép vùng loại nằm trong, hoặc có một phần trong vùng chọn.

Cảm ơn bạn đã đề ra phương án & cách giải nó!
Với macro của mình của bài trên, chưa chấp nhận việc nhập vùng có ô'Ngoài vùng phủ sóng' ;
Để Khách hàng là thượng đế, mình sửa lại như dười đây (thên 4 dòng lệnh & bỏ bớt vài dòng lệnh, như sau
Trích đoạn mã trước:

Sub SelectNoDeselectCells() 
 ' . . . . . '
 Set DRng = Range(InputBox("Hay Chon Dia Chi Bo Chon:")) 
 DDgD = DRng.Cells(1, 1).Row 
 DDgC = DDgD + DRng.Rows.Count - 1 
 DCTr = DRng.Cells(1, 1).Column 
 DCF = DCTr + DRng.Columns.Count - 1 
   
 If DDgD < LDgD Or DDgC > LDgC Or _ 
    DCTr < LCTr Or DCF > LCF Then 
    MsgBox "Dien Khong Vay?", , "GPE":      Exit Sub 
     
1 ElseIf DDgD = LDgD And DCF < LCF And DDgC < LDgC _ 
    And DCTr = LCTr Then 
    DDgD = LDgD + DRng.Rows.Count 
    Union(Range(Cells(LDgD, DCF + 1), Cells(LDgC, LCF)), _ 
        Range(Cells(DDgD, LCTr), Cells(LDgC, LCF))).Select 
         
2 ElseIf DDgD = LDgD And DCTr > LCTr And _ 
    DCF < LCF And DDgC < LDgC Then 
 ' . . . . . . . '

Được sửa lại như sau:

Sub SelectDeselectCells()
 '. . . . . . . . . .' 
 [B]Set DRng = Application.InputBox(prompt:="Select a DeSelectCells", Type:=8)[/B]

 [COLOR="Silver"]DDgD = DRng.Cells(1, 1).Row
 DDgC = DDgD + DRng.Rows.Count - 1
 DCTr = DRng.Cells(1, 1).Column
 DCF = DCTr + DRng.Columns.Count - 1[/COLOR] 
 [B]If DDgD < LDgD Then DDgD = LDgD
 If DDgC > LDgC Then DDgC = LDgC
 If DCTr < LCTr Then DCTr = LCTr
 If DCF > LCF Then DCF = LCF[/B] 
[COLOR="RoyalBlue"]' If DDgD < LDgD Or DDgC > LDgC Or _
    DCTr < LCTr Or DCF > LCF Then '
'    MsgBox "Ngoai Vung Phu Song!", , "GPE":      Exit Sub '[/COLOR]    
1 [COLOR="Purple"][B]If DDgD = LDgD And DCF < LCF And DDgC < LDgC _
    And DCTr = LCTr Then [/B][COLOR="Blue"]'*[/COLOR][/COLOR]

Nguyên tắc là anh/chị nào nằm ngoài thì không tính là vùng bỏ chọn.

Xin xem file đính kèm tại bài #8 mới cập nhật.​

 

[SA_DQ]

Mở rọng các vùng chọn không liên tục

1./ Ví dụ trước đó ta đã chọn các ô không liên tục (phần bên trái của hính); Sau khi chạy macro sẽ được kết quả (phần phải của hinh1)

(H1)

Option Explicit

Sub BigSelect()
 Dim NCRng As Range
 
 Set NCRng = Application.InputBox(prompt:="Select a NonContinueCells", Type:=8)
 If Not ResizeRange(NCRng) Is Nothing Then ResizeRange(NCRng).Select
End Sub

2./ Trước đó ta cũng đã chọn các ô không liên tục;
Sau khi macro được chạy, nó kích hoạt các ô chưa chọn trong hình chữ nhật bao các ô đã chọn:

 Sub SelectNoneSelectRange()
 Dim NoSRng As Range
 
 Set NoSRng = Application.InputBox(prompt:="Select a NonSelectCells", Type:=8)
  If Not ResizeRange(NoSRng, False) Is Nothing Then _
    ResizeRange(NoSRng, False).Select
  
End Sub

(H2)​

Function ResizeRange(sRng As Range, Optional MaxRng As Boolean = True) As Range
 Dim Clls As Range, DRng As Range, TRng As Range
 Dim TopRow As Long, BottomRow As Long
 Dim LeftCol  As Integer, RightCol As Integer
 
 TopRow = 65432:        BottomRow = 1
 LeftCol = 255:         RightCol = 1
 For Each Clls In sRng
    If TopRow > Clls.Row Then TopRow = Clls.Row
    If BottomRow < Clls.Row Then BottomRow = Clls.Row
    If LeftCol > Clls.Column Then LeftCol = Clls.Column
    If RightCol < Clls.Column Then RightCol = Clls.Column
 Next Clls
 
 Set DRng = Range(Cells(TopRow, LeftCol), Cells(BottomRow, RightCol))
 If MaxRng Then
    Set ResizeRange = DRng:     Exit Function
 End If
    
 For Each Clls In DRng
    If Intersect(Clls, sRng) Is Nothing Then
        If TRng Is Nothing Then
            Set TRng = Clls
        Else
            Set TRng = Union(Clls, TRng)
    End If:         End If
 Next Clls
 If Not TRng Is Nothing Then Set ResizeRange = TRng
End Function

 

[phamduylong]

Bỏ chọn ô hay vùng nhỏ trong vùng lớn đã chọn coi như xong, SA_DQ và các bạn có thể phát triển thêm: Bỏ chọn nhiều ô hay nhiều vùng nhỏ trong vùng lớn, cái này có nhiều ứng dụng thực tế.

 

[SA_DQ]

Những nổ lực cũng được đền đáp!!

Các bạn có thể phát triển thêm: Bỏ chọn nhiều ô hay nhiều vùng nhỏ trong vùng lớn, cái này có nhiều ứng dụng thực tế.

Được rồi đây các bạn ơi! Các bạn kiểm thêm giúp mình, nha! (16 trường hợp có tại file đính kèm của bài 8)
Hàm ResizeRange() có tại bài 13

Option Explicit
Dim Rng As Range
Dim Clls As Range
Sub ChonCacOConLai()
 Dim ContRng As Range, SelectRng As Range
 Dim NoCont As Boolean
 Dim TRow As Long, BRow As Long
 Dim LCol As Integer, RCol As Integer
 
 ' Kiem & Loai Cac O Ngoai Khung'
 Set Rng = Selection
 TRow = Rng.Cells(1, 1).Row:        BRow = TRow + Rng.Rows.Count - 1
 LCol = Rng.Cells(1, 1).Column:     RCol = LCol + Rng.Columns.Count - 1
 Set Rng = Nothing
 Set SelectRng = Application.InputBox(prompt:="Select a DeSelectCells", Type:=8)
 For Each Clls In SelectRng
    If Clls.Row >= TRow And Clls.Row <= BRow And Clls.Column >= LCol And _
        Clls.Column <= RCol Then
        If Rng Is Nothing Then
            Set Rng = Clls
        Else
            Set Rng = Union(Rng, Clls)
    End If:             End If
 Next Clls
 
 If Rng.Cells.Count < ResizeRange(Rng).Cells.Count Then
    Set ContRng = ResizeRange(Rng, False)
    Set Rng = ResizeRange(Rng):          NoCont = True
 End If
 Dim DgTr As Long, DgD As Long
 Dim CotTr As Integer, CotF As Integer
 
 DgTr = Rng.Cells(1, 1).Row:        DgD = DgTr + Rng.Rows.Count - 1
 CotTr = Rng.Cells(1, 1).Column:    CotF = CotTr + Rng.Columns.Count - 1
 Set Rng = Nothing
 Dim RightR As Range, TopR As Range, LeftR As Range, BottomR As Range
 If TRow = DgTr Then
   If DgD < BRow Then
        Set BottomR = Range(Cells(DgD + 1, LCol), Cells(BRow, RCol))
1       If CotTr = LCol And CotF < RCol Then
            Set RightR = Range(Cells(TRow, CotF + 1), Cells(DgD, RCol))
            Set SelectRng = Union(RightR, BottomR)
2       ElseIf CotTr > LCol And CotF < RCol Then
            Set LeftR = Range(Cells(TRow, LCol), Cells(DgD, CotTr - 1))
            Set RightR = Range(Cells(TRow, CotF + 1), Cells(DgD, RCol))
            Set SelectRng = Union(LeftR, RightR, BottomR)
3       ElseIf CotTr > LCol And CotF = RCol Then
            Set LeftR = Range(Cells(TRow, LCol), Cells(DgD, CotTr - 1))
            Set SelectRng = Union(LeftR, BottomR)
4       ElseIf CotTr = LCol And CotF = RCol Then
            Set SelectRng = BottomR
        End If
    ElseIf DgD = BRow Then
5       If CotTr = LCol And CotF < RCol Then
            Set RightR = Range(Cells(TRow, CotF + 1), Cells(BRow, RCol))
            Set SelectRng = RightR
6       ElseIf CotTr > LCol And CotF < RCol Then
            Set LeftR = Range(Cells(TRow, LCol), Cells(BRow, CotTr - 1))
            Set RightR = Range(Cells(TRow, CotF + 1), Cells(BRow, RCol))
            Set SelectRng = Union(LeftR, RightR)
7       ElseIf CotTr > LCol And CotF = RCol Then
            Set LeftR = Range(Cells(TRow, LCol), Cells(BRow, CotTr - 1))
            Set SelectRng = LeftR
8       ElseIf CotTr = LCol And CotF = RCol Then
            If NoCont Then
                ContRng.Select
            Else
                msgbox "No Range Select."
            End If
            Exit Sub
        End If
    End If
 ElseIf TRow < DgTr Then
    If DgD < BRow Then
        Set TopR = Range(Cells(TRow, LCol), Cells(DgTr - 1, RCol))
        Set BottomR = Range(Cells(DgD + 1, LCol), Cells(BRow, RCol))
9       If LCol = CotTr And RCol > CotF Then
            Set RightR = Range(Cells(DgTr, CotF + 1), Cells(DgD, RCol))
            Set SelectRng = Union(TopR, RightR, BottomR)
10      ElseIf LCol < CotTr And RCol > CotF Then
            Set RightR = Range(Cells(DgTr, CotF + 1), Cells(DgD, RCol))
            Set LeftR = Range(Cells(DgTr, LCol), Cells(DgD, CotTr - 1))
            Set SelectRng = Union(TopR, LeftR, RightR, BottomR)
11      ElseIf LCol < CotTr And RCol = CotF Then
            Set LeftR = Range(Cells(DgTr, LCol), Cells(DgD, CotTr - 1))
            Set SelectRng = Union(TopR, LeftR, BottomR)
12      ElseIf LCol = CotTr And RCol = CotF Then
            Set SelectRng = Union(TopR, BottomR)
        End If
    ElseIf DgD = BRow Then
        Set TopR = Range(Cells(TRow, LCol), Cells(DgTr - 1, RCol))
13      If LCol = CotTr And RCol > CotF Then
            Set RightR = Range(Cells(DgTr, CotF + 1), Cells(BRow, RCol))
            Set SelectRng = Union(TopR, RightR)
14      ElseIf LCol < CotTr And RCol > CotF Then
            Set RightR = Range(Cells(DgTr, CotF + 1), Cells(BRow, RCol))
            Set LeftR = Range(Cells(DgTr, LCol), Cells(BRow, CotTr - 1))
            Set SelectRng = Union(TopR, LeftR, RightR)
15      ElseIf LCol < CotTr And RCol = CotF Then
            Set LeftR = Range(Cells(DgTr, LCol), Cells(BRow, CotTr - 1))
            Set SelectRng = Union(TopR, LeftR)
16      ElseIf LCol = CotTr And RCol = CotF Then
            Set SelectRng = TopR
        End If
    End If
 End If
 If NoCont Then
    Union(SelectRng, ContRng).Select
 Else
    SelectRng.Select
 End If
End Sub

 

[phamduylong]

Được rồi đây các bạn ơi! Các bạn kiểm thêm giúp mình

Kiểm tra thấy ổn. Thank SA_DQ.

 

[SA_DQ]

. . .Copy nhiều vùng chọn rời rạc, chuyện mà Excel thông thường không làm được.

http://giaiphapexcel.com/forum/showthread.php?t=8448#3$11

Option Explicit
Dim Rng As Range
Dim StrC As String

Sub CopyMultipleSelections()
 Dim BigRng As Range, Clls As Range, DesRng As Range
 Dim RCount As Long, CCount As Integer
 
 StrC = "Select a NonContinueCells"
 Set Rng = Application.InputBox(prompt:=StrC, Title:="To Copy", Type:=8)
 If Not ResizeRange(Rng) Is Nothing Then Set BigRng = ResizeRange(Rng)
 
 RCount = BigRng.Rows.Count:            CCount = BigRng.Columns.Count
 StrC = "Select the Upperleft Cell for the Range to Paste:"
 Set DesRng = Application.InputBox(prompt:=StrC, Title:="Destination Cells", Type:=8)
 Set Rng = ResizeRange(Rng, False)
 For Each Clls In BigRng
    If Intersect(Clls, Rng) Is Nothing Then
        RCount = Clls.Row - BigRng.Cells(1, 1).Row
        CCount = Clls.Column - BigRng.Cells(1, 1).Column
        Clls.Copy Destination:=DesRng.Offset(RCount, CCount)
    End If
 Next Clls
End Sub

Xin xem thêm trong file đính kèm - Nhưng chỉ mới Copy - Páte trong Sheet mà thôi!

 

[ndu96081631]

1./ Ví dụ trước đó ta đã chọn các ô không liên tục (phần bên trái của hính); Sau khi chạy macro sẽ được kết quả (phần phải của hinh1)

Anh Sa ơi... Em nghĩ đoạn code về BigSelect của anh có thể rút gọn lại thành:

Option Explicit
Sub BigSelect()
 Dim NCRng As Range, BigRng As Range, i As Long
 On Error Resume Next
 Set NCRng = Application.InputBox(prompt:="Select a NonContinueCells", Type:=8)
 Set BigRng = NCRng.Areas(1)
 For i = 1 To NCRng.Areas.Count
   Set BigRng = Range(BigRng, NCRng.Areas(i))
 Next i
 BigRng.Select
End Sub

Và không cần đến bất cứ Function nào... Đồng thời em nghĩ For qua các Areas sẽ nhanh hơn For Each chứ nhỉ?
Không biết có vấn đề gì không? (xin anh góp ý giúp)

​

 

[ndu96081631]

Thừa thắng xông lên, em làm luôn 1 code copy nhiều vùng rời rạc!
1> Đầu tiên em biến Sub BigRange ở trên thành 1 Function:

Function BigRange(RCRng As Range) As Range
  Dim i As Long
  Set BigRange = RCRng.Areas(1)
  For i = 1 To RCRng.Areas.Count
    Set BigRange = Range(BigRange, RCRng.Areas(i))
  Next i
End Function

2> Cuối cùng là Sub chính

Sub CopyMultiSelect()
  Dim Src As Range, Des As Range, i As Long
  On Error Resume Next
  Set Src = Application.InputBox("Chon 1 vung hoac nhieu vung tuy y", Type:=8)
  Set Des = Application.InputBox("Chon 1 cell, noi can Paste du lieu", Type:=8)
  For i = 1 To Src.Areas.Count
    With BigRange(Src)
      Src.Areas(i).Copy Destination:=Src.Areas(i).Offset(Des.Row - .Row, Des.Column - .Column)
    End With
  Next
End Sub

Vẩn trên quan điểm quét qua các Areas
Điều đáng tiếc là 2 đoạn code này có 1 điểm chung:

For i = 1 To Vùng.Areas.Count

Nhưng lại không thế gộp chung lại (nên đành quét 2 lần: 1 trong Function và 1 trong Sub chính)

 

[tigertiger]

Thừa thắng xông lên, em làm luôn 1 code copy nhiều vùng rời rạc!
1> Đầu tiên em biến Sub BigRange ở trên thành 1 Function:

Vẩn trên quan điểm quét qua các Areas
Điều đáng tiếc là 2 đoạn code này có 1 điểm chung:
Nhưng lại không thế gộp chung lại (nên đành quét 2 lần: 1 trong Function và 1 trong Sub chính)

Vấn đề để làm gì a ndu ah, vì:

+ nếu trong VBA thì ta dùng lệnh gán là xong

+ vì thường ta viết VBA cho tự động thế thì bằng người dùng chọn làm gì cho vất vả, lại còn chọn không liên tục
.