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

 

[ndu96081631]

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
.

Mục đích là COPY NHIỀU VÙNG KHÔNG LIÊN TỤC thôi mà Tigertiger... Vì Excel đâu cho phép làm điều này (nên đành phải dùng VBA)
Thật sự đưa lên giãi pháp chỉ với ý đồ cải tiến cái có sẳn (của anh Sa).. qua đó hoàn thiện hơn những gì mình đã học từ các cao thủ... Còn việc dùng nó thế nào thì... để xem đã

 

[trphhai]

Các pac tài quá:
Sẳng đây các pac viết cho em 1 hàm nhé:
G(x1;x2) --> kết quả là 1 vùng tham chiếu từ x1 đến x2
Ví dụ G($A$1;$F$12) --> vùng tham chiếu $A$1:$F$12

 

[dangky47h]

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


Đượ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

E chào Thầy, Thầy ơi E chạy code trên bị lỗi là do đâu vậy Ạ! nhờ Thầy xem Giúp em, e cám ơn Thầy

 

[dangky47h]

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.​

E chạy code báo lỗi là do đâu vậy Thầy

 

[SA_DQ]

Thứ nhất: File của #23 máy mình không mở lên được; Nó báo có lỗi gì đó
Thứ nhì:

E chạy code báo lỗi là do đâu vậy

Qua hình mình thấy hình như bạn chưa {F5} để kiểm tra nhờ trình biên dịch thì fải!
Vì mình thấy đầu & cuối câu lệnh báo lỗi còn các kí hiệu dùng để Format in đâm cho câu ( [ B] và [ /B] ) thì fải?


Thứ ba: Rất cảm ơn bạn đã quan tâm đến vấn đề; Cái này là thời kì hồng hoang của GPE.COM kia đấy!
Cũng gần chục năm rồi, chả chơi!
Trong những bài đó có mấy bài của thầy giáo Long, giáo viên ĐT & thầy Tiger_Tiger Giảng viên Đại học TL;
Nhớ nhất chàng OKê BAP với lần rủ nhau uống Cà fê trên đường . . . . gì đó mà mình cũng quên là đường gì rồi!
& nữa: Là Nam dành ca với Thầy Long trong quán KaraOkê gần Từ Dũ!
Kính viếng hương hồn chàng OKê BAP & Thầy Phạm Duy Long!

 

[dangky47h]

Thứ nhất: File của #23 máy mình không mở lên được; Nó báo có lỗi gì đó
Thứ nhì: Qua hình mình thấy hình như bạn chưa {F5} để kiểm tra nhờ trình biên dịch thì fải!
Vì mình thấy đầu & cuối câu lệnh báo lỗi còn các kí hiệu dùng để Format in đâm cho câu ( [ B] và [ /B] ) thì fải?


Thứ ba: Rất cảm ơn bạn đã quan tâm đến vấn đề; Cái này là thời kì hồng hoang của GPE.COM kia đấy!
Cũng gần chục năm rồi, chả chơi!
Trong những bài đó có mấy bài của thầy giáo Long, giáo viên ĐT & thầy Tiger_Tiger Giảng viên Đại học TL;
Nhớ nhất chàng OKê BAP với lần rủ nhau uống Cà fê trên đường . . . . gì đó mà mình cũng quên là đường gì rồi!
& nữa: Là Nam dành ca với Thầy Long trong quán KaraOkê gần Từ Dũ!
Kính viếng hương hồn chàng OKê BAP & Thầy Phạm Duy Long!

Vâng, E cám ơn thầy, E tải file lên nhờ Thầy sửa giùm

 

[SA_DQ]

Mình mở file chưa được: