Giúp code VBa cách 6 dòng xóa 4 dòng tính từ hàng 1 trở xuống

[Văn Toàn 1996]

Chào các anh chị GPE. Em có 1 vùng A1:A1000 em muốn cứ cách 6 dòng, xóa đi 4 dòng thì phải dùng code VBA như thế nào. Xin cảm Ơn

 

[Hoàng Tuấn 868]

Mà bác ít code nên không biết thẻ rồi.

Có lẽ code ngắn quá nên không cần đưa vào thẻ.

 

[HeSanbi]

Code không khó lắm, quan trọng là đề bài phải dễ.

Option Explicit

Sub zzz()
Dim i&
Dim OHienTai As Range
For i = 1 To 1000 Step 1
Set OHienTai = Range("A" & i)
If [OHienTai] = 7 Or [OHienTai] = 8 Or [OHienTai] = 9 Or [OHienTai] = 10 Then
[OHienTai].EntireRow.Delete
i = i - 1
End If
Next
End Sub

Lệnh Delete Range, bác sử dụng quá tùy tiện. Các lỗi của cách viết mã như trên:
1. Mỗi lần Delete là toàn bộ công thức trong trang tính sẽ tính toán lại, chứ không riêng gì các công thức liên quan đến vùng đã xóa. Vòng lặp sẽ gọi rất nhiều lần Delete.
2. Nếu dưới 1000 dòng có một vùng dữ liệu khác, vùng ô đó sẽ dịch chuyển lên.
3. Giải thuật không có.

 

[Hoàng Tuấn 868]

Mà bác ít code nên không biết thẻ rồi.

Có lẽ code ngắn quá nên không cần đưa vào thẻ.

 

[cantl]

Lệnh Delete Range, bác sử dụng quá tùy tiện. Các lỗi của cách viết mã như trên:
1. Mỗi lần Delete là toàn bộ công thức trong trang tính sẽ tính toán lại, chứ không riêng gì các công thức liên quan đến vùng đã xóa. Vòng lặp sẽ gọi rất nhiều lần Delete.
2. Nếu dưới 1000 dòng có một vùng dữ liệu khác, vùng ô đó sẽ dịch chuyển lên.
3. Giải thuật không có.

Đúng là tớ code rất dỏm, vì tớ học code theo kiểu từ ngọn về gốc. Vì thế nên cứ ra kết quả là tớ mãn nguyện rồi.

Việc dữ liệu nhiều hay ít thì nó lại là đặc trưng của mỗi một bài, chắc là trách tác giả đưa ra dữ liệu ban đầu 1.000 dòng và cứ 1 đến 10 liên tục.

Tớ cũng rất hâm mộ code của bạn nhưng mà để đọc hiểu thì quá sức của tớ.

Nói chung phải cần các bạn trên diễn đàn hỗ trợ nhiều.

 

[VetMini]

..., tiết kiệm rất nhiều khoảng trống.
Mà bác ít code nên không biết thẻ rồi.

Có lẽ code ngắn quá nên không cần đưa vào thẻ.

Máy tôi bị lỗi cứ gõ hai dấu cách liên tiếp là nó nổi khùng. Vì vậy tôi viết code không thụt ra thụt vào cho nó khỏe.

 

[SA_DQ]

. . . ;.
1. . . . .
2. Nếu dưới 1000 dòng có một vùng dữ liệu khác, vùng ô đó sẽ dịch chuyển lên.
3. . . . .

Cách để khắc phục nhược điểm (2) này cũng có & mình nghỉ là vầy:
a./ Tìm dòng cuối có DL (dữ liệu) của vùng 'trên' & gán vô biến Rws;
b./ Khai báo 1 mảng để chứa DL kết quả & có số dòng trùng với Rws
c./ Tạo vòng lặp duyệt từ 1 cho đến Rws;
d./ Chỉ ghi vô mảng các dòng DL thỏa (Khác 7, 8, 9 & 10, . . . .)
e./ Ghi DL từ mảng lên trang tính;

Mong các nhận xét của các bạn gần xa!

 

[cantl]

Bác đã có dòng để nhét vào hàm Chuc() rồi thì cứ lấy dòng đấy chèn 4 dòng trống sau mỗi vòng lặp thôi mà.

Cách để khắc phục nhược điểm (2)

cho các vùng bên dưới, ví dụ có 5 vùng cách nhau, em chưa nghĩ được cách để tìm dòng giới hạn của từng vùng.
Code bạn bi hay chỗ Undo được. Còn xóa mà không đẩy lên thì em cũng thấy hơi lạ, cần phải có ứng dụng điển hình mới được.

Còn bác có đam mê tối ưu thì đây, em trình code đểu trước + code Google dịch từ tiếng Việt sang tiếng VBA của bác Thắng luôn, dịch y từng chữ.

Và Chuc() của bác hại não quá, em phải lập bảng mới hiểu được.

Option Explicit

Sub Xoa4DongCua1chuc()
Dim x&, i&
x = Chuc(Cells(Rows.Count, "A").End(xlUp).Row)
For i = (x + 7) To 1 Step -10
Cells(i, 1).Resize(4).EntireRow.Delete
Next
End Sub

Function Chuc(NumR As Integer)
 Chuc = Int(NumR / 10) * 10
End Function

Sub zzz()
Dim i&, DongDau&, DongCuoi&
Dim OHienTai As Range, OVung As Range, VVung As Range
Set OVung = Application.InputBox("Chon vung:", , , , , , , 8)
Set VVung = OVung.CurrentRegion
DongCuoi = VVung.End(xlDown).Row
DongDau = Cells(DongCuoi, "A").End(xlUp).Row
For i = DongCuoi To DongDau Step -1
Set OHienTai = Range("A" & i)
If (OHienTai.Row - (DongDau - 1) - 1) Mod 10 + 1 > 6 Then
OHienTai.EntireRow.Delete
Cells(DongCuoi + 1, "A").EntireRow.Insert
End If
Next
End Sub

 

[SA_DQ]

cho các vùng bên dưới, ví dụ có 5 vùng cách nhau, em chưa nghĩ được cách để tìm dòng giới hạn của từng vùng.

Đây là cách thô nhất có thể để tìm ra dòng cuối của vùng 1 (trên nhất) có chứa dữ liệu:

Sub TimDongCuoiCuaVung1()
 Dim fRw As Integer, lRw As Long
 
 If [A1].Value <> Space(0) Then
    fRw = 1
 Else
    fRw = [A1].End(xlDown).Row
 End If
 lRw = Cells(fRw, "A").End(xlDown).Row
 MsgBox lRw
End Sub

 

[nnthoi1994]

Chào các anh chị GPE. Em có 1 vùng A1:A1000 em muốn cứ cách 6 dòng, xóa đi 4 dòng thì phải dùng code VBA như thế nào. Xin cảm Ơn
View attachment 298757

Bạn dùng AI chưa, tôi hỏi nó trả lời code chính xác = ))))

 

[HeSanbi]

@cantl Lệnh Delete và Insert Range chỉ sử dụng trong tình thế cần mới nên sử dụng.
Dưới đây là một đoạn mã dùng giải thuật dồn hàng an toàn. Và viết ít mã hơn.
Nếu gọi lần 2 trong vòng 7 giây sẽ hoàn tác.
(Nếu sử dụng phương pháp xử lý XML sẽ giữ được Công thức, nếu có.)

Private Sub ClearStepRows_test()
 ClearStepRows [A1:C60], 6, 4
End Sub
Sub ClearStepRows(ByVal table As Range, Optional ByVal stepRows& = 1, Optional ByVal ClearRows& = 1)
  Dim d$: d = table.Address(0, 0, , 1)
  Static t!, a, s$:
  If table Is Nothing Then a = Empty: t = 0: s = Empty: Exit Sub
  If t > 0 And (Timer - t < 0) Then
    If d = s Then table = a: t = 0: Exit Sub
  End If
  Dim k&, r&, lr&, fr&, lc&, c&, z
  a = table.Value
  lr = UBound(a): lc = UBound(a, 2)
  stepRows = IIf(stepRows < 1, 1, stepRows)
  ClearRows = IIf(ClearRows < 1, 1, ClearRows)
  ReDim z(1 To lr, 1 To lc)
  While r < lr
    r = r + 1
    For c = 1 To lc
      z(r - k, c) = a(r, c)
    Next c
    fr = ((r - 1) Mod cr) + 1
    If fr >= stepRows Then r = r + ClearRows: k = k + ClearRows
  Wend
  table = z
  t = Timer + 7: s = d
  Application.OnTime Now + TimeSerial(0, 0, 7), "'" & ThisWorkbook.Name & "'!ClearStepRows_FreeMemory"
End Sub

Sub ClearStepRows_FreeMemory()
  ClearStepRows Nothing
End Sub

Dưới đây là đoạn mã sử dụng lệnh Delete Range, mã này không áp dụng cho mỗi 2 dòng được Gộp ô:

Private Sub DeleteStepRows_test()
  DeleteStepRows [A1:C60], 6, 4
End Sub

Sub DeleteStepRows(ByVal table As Range, Optional ByVal stepRows& = 1, Optional ByVal ClearRows& = 1)
  Dim k&, r&, lr&, lc&, cr&, rg As Range
  stepRows = IIf(stepRows < 1, 1, stepRows)
  ClearRows = IIf(ClearRows < 1, 1, ClearRows)
  cr = stepRows + ClearRows
  If MsgBox("Xóa vùng ô " & table.Address(0, 0) & ":" & vbLf & _
            "   Cách " & stepRows & " xóa " & ClearRows & " dong" & vbLf & _
            "        (Hanh dong nay không the hoan tac)" & vbLf & _
            "        Tiêp tuc?", _
         vbYesNo, Title:="Rows Delete") <> vbYes Then Exit Sub
  lr = table.rows.CountLarge:
  lc = table.columns.CountLarge:
  While r < lr
    r = r + stepRows
    If Not rg Is Nothing Then
      Set rg = Union(rg, table(r + 1, 1).Resize(ClearRows, lc))
    Else
      Set rg = table(r + 1, 1).Resize(ClearRows, lc)
    End If
    r = r + ClearRows
  Wend
  If Not rg Is Nothing Then rg.Delete xlShiftUp

End Sub

 

[huuthang_bd]

Code bạn bi hay chỗ Undo được. Còn xóa mà không đẩy lên thì em cũng thấy hơi lạ, cần phải có ứng dụng điển hình mới được.

Do với cách làm đó thì không thể làm cho phần dữ liệu bên dưới đẩy lên theo được. Nhưng thay vì nói rõ nhược điểm đó tác giả lại cố tình nói việc đẩy dữ liệu lên như bình thường là nhược điểm để bạn ngầm hiểu không đẩy dữ liệu lên là ưu điểm.
Code mà thấy dùng Sendkey là tôi không khoái rồi. Làm theo hướng đó thì cũng không cần phải dùng một đống API như vậy.

 

[ptm0412]

Tôi xóa các bài tranh cãi bên trên, đồng thời cảnh cáo nick @HeSanbi và ban nick 1 tháng do dùng từ ngữ để mắng chửi người khác mà lại mang tính vơ đũa cả nắm.
Tôi cũng là người không thích dùng API, nếu viết code bằng VBA dược bằng năm ba dòng lệnh thì không dùng API cả thước code. Như vậy tôi cũng bị chửi chung là chó à?
Trích hình ảnh trước khi xóa:

 

[SA_DQ]

@SA_DQ Theo em thì cách giải bài của bác
1. Sử dụng XML API
2. Giải thuật bước nhảy
3. Dùng vòng lặp
Em đang hoàn thành mã, giải thuật khó quá, nên hơi lâu
----------------------------------------------------
. . . . .

Mình xin đăng lại (gần đúng) bài hỏi của mình, để ai đó khỏi lăn tăn:
Giả sử phía dưới vùng DL (dữ liệu) thứ nhất có vài ba dòng trắng & sau đó là vùng DL thứ 2 ở bên dưới;
Vậy làm sao ta có thể xóa các dòng thứ 7 đến dòng 10 trong từng chục dòng của vùng DL thứ nhất, sao cho yên vị (không đôn) vùng DL thứ 2 lên trên.

 

[huuthang_bd]

Mình xin đăng lại (gần đúng) bài hỏi của mình, để ai đó khỏi lăn tăn:
Giả sử phía dưới vùng DL (dữ liệu) thứ nhất có vài ba dòng trắng & sau đó là vùng DL thứ 2 ở bên dưới;
Vậy làm sao ta có thể xóa các dòng thứ 7 đến dòng 10 trong từng chục dòng của vùng DL thứ nhất, sao cho yên vị (không đôn) vùng DL thứ 2 lên trên.

Nếu muốn như vậy thì xóa bao nhiêu dòng thì chèn lại bấy nhiêu dòng sau dòng cuối cùng là được mà.

 

[SA_DQ]

Mình mới nghỉ ra cách này & tự cho là đơn giản đối với mình:

a./ Xác định dòng cuối (lRws) có DL (dữ liệu) của vùng trên cùng (là vùng cần xóa 4 cho mỗi 1 chục dòng);
b./ Khai báo 1 mảng có chỉ số dòng bằng với trị đã xác đinh trên.
c./ Tạo vòng lặp duyệt từ 1 đến lRws;
Dòng nào không thỏa điều kiện xóa thì ghi vô mảng
d./ Chuyển DL trong mảng lên trang tính

PC: Nếu DL vùng I này không bình thường thì sẽ bổ sung chuyện xử lý sau, . . . .

 

[cantl]

Mình mới nghỉ ra cách này & tự cho là đơn giản đối với mình:

a./ Xác định dòng cuối (lRws) có DL (dữ liệu) của vùng trên cùng (là vùng cần xóa 4 cho mỗi 1 chục dòng);
b./ Khai báo 1 mảng có chỉ số dòng bằng với trị đã xác đinh trên.
c./ Tạo vòng lặp duyệt từ 1 đến lRws;
Dòng nào không thỏa điều kiện xóa thì ghi vô mảng
d./ Chuyển DL trong mảng lên trang tính

PC: Nếu DL vùng I này không bình thường thì sẽ bổ sung chuyện xử lý sau, . . . .

Cách của bác giống bạn HeSanbi. Code bạn ấy có Ctrl+V.
Khổ thân bạn ấy, ban nick nên gõ @ không triệu hồi được.

 

[befaint]

Dùng SendKey mà không ghi chú to đùng lên rằng "Khi thực hiện cấm người dùng động đậy bàn phím" thì vứt rồi.

Lại còn dùng Union nữa chứ. Union tưởng là ngon nhưng chẳng ngon tẹo nào, có một giới hạn mà tại đó union lăn ra đơ đơ (có một chủ đề về vấn đề này rồi). Kinh nghiệm còn non hoặc chưa chịu khó tét code trong phòng thí nghiệm đủ 3 tháng rồi.

 

[Quang_Hải]

Sub Xoa_Dong()
Dim sArr(), dArr(), k As Long, i As Long, ii As Long
sArr = Range("A1", Range("A" & Rows.Count).End(3)).Resize(, 2).Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 4 Step 10
    For ii = 0 To 5
        k = k + 1
        dArr(k, 1) = sArr(i + ii, 1)
        dArr(k, 2) = sArr(i + ii, 2)
    Next
Next
Range("E1").Resize(k, UBound(dArr, 2)) = dArr
End Sub

Theo mình thì code cơ bản chắc cũng được rồi

 

[ptm0412]

Cách của bác giống bạn HeSanbi. Code bạn ấy có Ctrl+V.

Cách của bác Sa làm gì có copy paste mà có Ctrl V?

 

[cantl]

Cách của bác Sa làm gì có copy paste mà có Ctrl V?

À, theo cách hiểu không bài bản của em thì cứ gắn mảng xuống bảng tính thì nó cũng giống giống control v.
Còn cách thức chính xác thì em cũng không biết gọi tên là gì.