Nhờ các chú/bác,anh/chị trong diễn đàn giúp em tăng tốc code này với (1 người xem)

[thungdols]

tình hình là em tự viết cái code để xóa ô trống với
câu lệnh: cell.delete shift:=xlup
nhưng xóa tầm 10 cột và vài chục dòng thì ok. Nhưng nếu xóa tầm 150 cột và khoảng 5000 dòng thì đợi cả tiếng đồng hồ mà không xong. Ai có cách giúp em viết cái code có thể trong 10 phút là xóa được không. Em chân thành cám ơn
Ps: code xóa và tệp tin đính kèm

Private Sub CommandButton1_Click()Dim rc As Long, n As Integer
 
 rc = Sheet1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
 Do
    For n = 1 To 10
      If Sheet1.Cells(rc, n + 1).Value = "" Then
       Sheet1.Cells(rc, n + 1).Delete Shift:=xlUp
      End If
    Next n
 rc = rc - 1
Loop While rc > 1
Sheet1.Activate
End Sub

 

[phihndhsp]

tình hình là em tự viết cái code để xóa ô trống với
câu lệnh: cell.delete shift:=xlup
nhưng xóa tầm 10 cột và vài chục dòng thì ok. Nhưng nếu xóa tầm 150 cột và khoảng 5000 dòng thì đợi cả tiếng đồng hồ mà không xong. Ai có cách giúp em viết cái code có thể trong 10 phút là xóa được không. Em chân thành cám ơn
Ps: code xóa và tệp tin đính kèm

Private Sub CommandButton1_Click()Dim rc As Long, n As Integer
 
 rc = Sheet1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
 Do
    For n = 1 To 10
      If Sheet1.Cells(rc, n + 1).Value = "" Then
       Sheet1.Cells(rc, n + 1).Delete Shift:=xlUp
      End If
    Next n
 rc = rc - 1
Loop While rc > 1
Sheet1.Activate
End Sub

Giúp bạn 1 vé, 5000 dòng và 150 cột, bạn test thử xem sao (5s cho 5000 dòng và 150 cột ok ?)

Sub GPE01(rc As Long, Rng As Range, Arr(), Socot As Long)
Dim Ii As Long
Dim I As Long, j As Long
   Ii = 1
   For I = 1 To rc
          If (Rng(I, Socot) <> "") Then
               Arr(Ii, Socot) = Rng(I, Socot)
                  Ii = Ii + 1
         End If
  Next I
 End Sub

Sub GPE02()
Dim rc As Long
Dim Arr()
Dim Rng As Range
Dim I As Long
 rc = Sheet1.Range("A60000").End(xlUp).Row
 Set Rng = Sheet1.Range("B2:ET" & rc)
 ReDim Arr(1 To rc, 1 To 150)
    For I = 1 To 150
        Call GPE01(rc, Rng, Arr, I)
     Next
        Sheet1.Range("B2").Resize(rc, I) = Arr
End Sub

Sorry hết quota để tải bài lên bạn thông cảm

 

[leonguyenz]

Record Marco: Chọn vùng B2:K16, F5 > Special... > Constants > Bỏ check Numbers > Ok. Nhấn tổ hợp phím Ctrl + - > Enter > Stop Recording (dừng Marco).
Alt + F11 > rút gọn Marco như sau:

Sub Macro1()
    Range("B2:K16").SpecialCells(xlCellTypeConstants, 22).Delete Shift:=xlUp
End Sub

Test dùm cả bảng tính xem mất bao nhiêu thời gian.

 

[phihndhsp]

Record Marco: Chọn vùng B2:K16, F5 > Special... > Constants > Bỏ check Numbers > Ok. Nhấn tổ hợp phím Ctrl + - > Enter > Stop Recording (dừng Marco).
Alt + F11 > rút gọn Marco như sau:

Sub Macro1()
    Range("B2:K16").SpecialCells(xlCellTypeConstants, 22).Delete Shift:=xlUp
End Sub

Test dùm cả bảng tính xem mất bao nhiêu thời gian.

chọn bằng tay thôi mà đã đứng máy 20 phút

 

[leonguyenz]

chọn bằng tay thôi mà đã đứng máy 20 phút

Đúng là chưa test, ai biết số ô có thể chọn để dùng phương thức SpecialCells hay không?

 

[Quang_Hải]

tình hình là em tự viết cái code để xóa ô trống với
câu lệnh: cell.delete shift:=xlup
nhưng xóa tầm 10 cột và vài chục dòng thì ok. Nhưng nếu xóa tầm 150 cột và khoảng 5000 dòng thì đợi cả tiếng đồng hồ mà không xong. Ai có cách giúp em viết cái code có thể trong 10 phút là xóa được không. Em chân thành cám ơn
Ps: code xóa và tệp tin đính kèm

Private Sub CommandButton1_Click()Dim rc As Long, n As Integer
 
 rc = Sheet1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
 Do
    For n = 1 To 10
      If Sheet1.Cells(rc, n + 1).Value = "" Then
       Sheet1.Cells(rc, n + 1).Delete Shift:=xlUp
      End If
    Next n
 rc = rc - 1
Loop While rc > 1
Sheet1.Activate
End Sub

Sub ThuGon()
Dim arr(), res(), i, j, k
arr = [B2:K16].Value
ReDim res(1 To UBound(arr), 1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2)   
   For i = 1 To UBound(arr)
      If arr(i, j) <> "" Then
         k = k + 1
         res(k, j) = arr(i, j)
      End If
   Next
   k = 0
Next[B2].Resize(i - 1, UBound(arr, 2)) = res
End Sub