Code xóa dữ liệu không chạy. (1 người xem)

[LuuAnh980]

Em dùng đoạn code này để xóa dữ liệu cột D3 đến E, và cột J, và cột L của sheet Beginning.
Mà chạy code không thấy chạy ạ.
Mong các anh chỉ giúp em sai chổ nào ạ. Thông cảm em dùng điện thoại, nên chỉ chụp hình.

 

[truongvu317]

Sub XoaDuLieu()
    Dim sH As Worksheet, lR As Long, i As Long, aColDele
    Set sH = ThisWorkbook.Sheets("Beginning")
    
    
    lR = sH.Cells(sH.Rows.Count, 4).End(xlUp).Row
    If lR <= 2 Then Exit Sub ' dong so 2 la header: no data
    aColDele = Array("D", "E", "J", "L")
    For i = LBound(aColDele) To UBound(aColDele)
        sH.Range(aColDele(i) & 3).Resize(lR - 3 + 1).ClearContents
    Next i
      
End Sub

Thử code này xem

 

[VetMini]

Sub XoaDuLieu()
    Dim sH As Worksheet, lR As Long, i As Long, aColDele
    Set sH = ThisWorkbook.Sheets("Beginning")
   
   
    lR = sH.Cells(sH.Rows.Count, 4).End(xlUp).Row
    If lR <= 2 Then Exit Sub ' dong so 2 la header: no data
    aColDele = Array("D", "E", "J", "L")
    For i = LBound(aColDele) To UBound(aColDele)
        sH.Range(aColDele(i) & 3).Resize(lR - 3 + 1).ClearContents
    Next i
     
End Sub

Thử code này xem

Người ta đã xác nhận có code chạy được rồi. Thêm nữa mà chi.
Chỗ Array còn luộm thuộm lắm. Viết gọn hơn:
Dim colTxt
For Each colTxt In Array("D", "E", "J", "L")
' hoặc ... In [ {"D", "E", "J", "L"} ]
' hoặc ... In Split("D, E, J, L", ", ")
' đằng nào cũng ra colTxt là một ký tự (chuỗi)
sH.Range(colTxt & 3 & ":" & colTxt & lR).ClearContents
Next colTxt

 

[truongvu317]

Người ta đã xác nhận có code chạy được rồi. Thêm nữa mà chi.
Chỗ Array còn luộm thuộm lắm. Viết gọn hơn:
Dim colTxt
For Each colTxt In Array("D", "E", "J", "L")
' hoặc ... In [ {"D", "E", "J", "L"} ]
' hoặc ... In Split("D, E, J, L", ", ")
' đằng nào cũng ra colTxt là một ký tự (chuỗi)
sH.Range(colTxt & 3 & ":" & colTxt & lR).ClearContents
Next colTxt

Đúng rồi bác. Dùng cái split cho nó được nhiều

 

[VetMini]

Đúng rồi bác. Dùng cái split cho nó được nhiều

Nhiều chiều dài nhưng ít chiều ngang (kém uyển chuyển, chỉ dùng được cho text)

 

[HeSanbi]

@LuuAnh980 Bạn có thể sử dụng thủ tục tổng quát như sau:

Chỉ cần tạo một nút gán macro: 'RangeClears [D3:E3],[J3],[L3]'
Xóa tại trang khác: 'RangeClears [D3:E3],[J3],refCell("Trang tính 1",[D3:E3],[J3],[L3])'
Giới hạn vùng để không xóa dữ liệu phía dưới: [D3:E2000]




Sao chép dán thủ tục dưới vào một Module mã:

Sub RangeClears(ParamArray cells())
  On Error Resume Next
  Dim i, lr&, a
  For Each a In cells
    Select Case TypeName(a)
    Case "Range":
      For Each i In a.Areas
        lr = i.rows.Count
        lr = IIf(lr > 1, lr + 2, i.parent.rows.Count - i.row)
        lr = i(lr, 1).End(xlUp).row - i.row + 1
        If lr > 0 Then i.Resize(lr).ClearContents
      Next
    End Select
  Next
End Sub

Function refCell(Sheetname$, ParamArray cells()) As Range
  On Error Resume Next
  Dim o As Object, i, r As Range
  Set o = ActiveWorkbook.Worksheets(Sheetname)
  If Err <> 0 Or o Is Nothing Then
    For Each o In ActiveWorkbook.Worksheets
      If o.CodeName = Sheetname Then Exit For
    Next
  End If
  For Each i In cells
    Select Case TypeName(i)
    Case "Range":
      If r Is Nothing Then
        Set r = o.Range(i.Address)
      Else
        Set r = Union(r, o.Range(i.Address))
      End If
    End Select
  Next
  Set refCell = r
End Function