Xóa các nội dung tại ô khác của cột nếu có ô khác được lựa chọn trong cột

[pham ha 94]

Nhờ các bác hỗ trợ giúp
Như bảng bên dưới, hiện tại ô A9 đang được tích "x".
+ Nếu tích vào ô A3 (hoặc bất kỳ ô nào trong cột A) thì ô A9 (và các ô khác trong cột) sẽ bị xóa
+ Có thể insert thêm các ô vào giữa thì công thức không thay đổi
Em xin cảm ơn cả nhà

 

[bebo021999]

Dùng sự kiện worksheet_Change nhé
Click chuột phải và tên sheet, View Code, rồi dán code phía dưới vào:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&
lr = Cells(Rows.Count, "B").End(xlUp).Row
If Intersect(Target, Range("A2:A" & lr)) Is Nothing Or Target.Count > 1 Or UCase(Target) <> "X" Then Exit Sub
With Application
    .EnableEvents = False
    Range("A2:A" & lr).ClearContents
    Target.Value = "X"
    .EnableEvents = True
End With
End Sub

 

[pham ha 94]

Cảm ơn bạn nhiều, hiện tại mình áp dụng theo thì gặp lỗi Nếu xóa dòng bất kỳ (dòng i) thì dòng (i+1) sẽ xóa hết dữ liệu về dấu "x". Không biết khắc phục như nào
code minh giu nhu ben duoi:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&
lr = Cells(Rows.Count, "B").End(xlUp).Row
If Intersect(Target, Range("A2:A" & lr)) Is Nothing Then Exit Sub
With Application
.EnableEvents = False
Range("A2:A" & lr).ClearContents
Target.Value = "x"
.EnableEvents = True
End With
End Sub

 

[bebo021999]

Bạn mô tả lại kỹ nhé:
1 hình trước khi tích
1 hình sau khi tích

 

[pham ha 94]

Lỗi phát sinh khi thực hiện xóa hoặc insert dòng mới, còn việc xóa dòng thì chạy ổn rồi bạn ạ

 

[HeSanbi]

Bạn xem thử mã dưới đây, với ràng buộc duy nhất 1 ô thay đổi trong cột tick x.

Để chèn dòng, cột không bị lỗi bạn phải đặt Name tên TickCells với vùng A2:A... nhé

Private Sub Worksheet_Change(ByVal t As Range)
  Static tm!: If tm > (Timer - 0.1) Then Exit Sub
  Dim rg As Range, v
  Set rg = Range("TickCells")
  If Not CellSingle(t, rg) Then Exit Sub
  v = t.Value: If v = Empty Then Exit Sub
  tm = Timer
  On Error Resume Next
  Set rg = rg.SpecialCells(2): If Not rg Is Nothing And Err = 0 Then rg.ClearContents
  t.Value = v:
End Sub
Function CellSingle(ByVal t As Range, Optional ByVal Target As Range) As Boolean
  On Error Resume Next
  CellSingle = t(1, 1).MergeArea.Address = t.Address
  If CellSingle Then If Not Target Is Nothing Then CellSingle = (t.Column = Target.Column) And (t.Row >= Target.Row) And (t.Row < (Target.Row + Target.Rows.Count))
  On Error GoTo 0
End Function

 

[pham ha 94]

Private Sub Worksheet_Change(ByVal t As Range) Static tm!: If tm > (Timer - 0.05) Then Exit Sub Dim rg As Range, v Set rg = t.Parent.Range("TickCells") If Not CellSingle(t, rg) Then Exit Sub v = t.value: If v = Empty Then Exit Sub Set rg = rg.SpecialCells(2): If Not rg Is Nothing Then rg.ClearContents t.value = v: tm = Timer End Sub Function CellSingle(ByVal t As Range, Optional ByVal Target As Range) As Boolean On Error Resume Next CellSingle = t(1, 1).MergeArea.Address = t.Address If CellSingle Then If Not Target Is Nothing Then CellSingle = (t.Column = Target.Column) And (t.Row >= Target.Row) And (t.Row < (Target.Row + Target.Rows.Count)) On Error GoTo 0 End Function

Minh copy toan bo code vao sheet1 thi thay bao loi tai dong 4: Set rg = t.Parent.Range("TickCells")

 

[Maika8008]

Minh copy toan bo code vao sheet1 thi thay bao loi tai dong 4: Set rg = t.Parent.Range("TickCells")

Bạn đã đặt tên vùng TickCells ở sheet1 chưa?

 

[pham ha 94]

minh tao roi nhung van khong chay b a

 

[HeSanbi]

View attachment 286934
minh tao roi nhung van khong chay b a

Xóa để lại chỉ còn Range("TickCells") vì bạn đã đặt Scope toàn cục (workbook)

 

[pham ha 94]

Ban xem giup minh duoc khong, bao loi suot y

 

[HeSanbi]

Ban xem giup minh duoc khong, bao loi suot y

Set rg = t.Parent.Range("TickCells")
Thành:
Set rg = Range("TickCells")

 

[Maika8008]

Tôi thấy lỗi logic gì đó ở code. Chạy lặp lại 1 chút thì đơ và thoát Excel luôn.

 

[pham ha 94]

Chạy một xíu là sẽ đơ và mất code đóng file excel luôn ý

 

[HeSanbi]

Chạy một xíu là sẽ đơ và mất code đóng file excel luôn ý

Bạn chép lại mã, thử lại xem sao

 

[pham ha 94]

Bạn chép lại mã, thử lại xem sao

b có thể xem giúp mình file m đính kèm bên trên được không, mình thử code nhiều lần vẫn lỗi.
Cảm ơn bạn nhiều

 

[HeSanbi]

b có thể xem giúp mình file m đính kèm bên trên được không, mình thử code nhiều lần vẫn lỗi.
Cảm ơn bạn nhiều

Bạn kiểm thử lại xem sao

 

[pham ha 94]

cam on ban nhieu, minh lam duoc roi

 

[pham ha 94]

Dùng sự kiện worksheet_Change nhé
Click chuột phải và tên sheet, View Code, rồi dán code phía dưới vào:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&
lr = Cells(Rows.Count, "B").End(xlUp).Row
If Intersect(Target, Range("A2:A" & lr)) Is Nothing Or Target.Count > 1 Or UCase(Target) <> "X" Then Exit Sub
With Application
    .EnableEvents = False
    Range("A2:A" & lr).ClearContents
    Target.Value = "X"
    .EnableEvents = True
End With
End Sub

Mình Sửa lại code này một chút ở dòng Target.Value = "X" thành Cells(Target.Row, "A").Value = "X"
Khi insert cũng không bị tích x cả hàng mà chỉ đánh X vào cột A thôi