Nhờ rút gọn đoạn code để chạy nhanh hơn và hiện thông báo (1 người xem)

[thienthanvuive]

Chào các bạn

Mình có 1 đoạn marco làm 4 việc
- Tính doanh số bán trong ngày
- Tính lãi
- Tính hàng tồn
- Tính chi phí trong ngày

4 việc này trong marco có tách riêng thành 4 đoạn
1. Nhờ các bạn cho giúp đoạn code hiện thông báo đang tính gì đó. Ví dụ khi đang tính lãi thì hiện thông báo "Đang tính lãi"

2. Mình có đoạn code này khi chạy thấy mất thời gian, vì dữ liệu của mình gần 50 nghìn dòng. Ý nghĩa đoạn này: tìm những dòng ở cột thứ 5 có giá trị là 70 thì xóa dòng đó (dòng thứ 2 trở đi)

i = 1
Do While Cells(i + 1, 5) <> ""
If Cells(i + 1, 4) = "70" Then
Rows(i).Select
Selection.Delete Shift:=xlUp
Else
i = i + 1
End If
Loop

Nhờ các bạn thay thế giúp mình đoạn code khác giúp máy chạy nhanh hơn

Cám ơn nhiều

 

[sealand]

Để có hỗ trợ tốt thì bạn fải có ví dụ cụ thể về số liệu, cột, hàng, công thức như file gốc của bạn

 

[Quang_Hải]

Chào các bạn

Mình có 1 đoạn marco làm 4 việc
- Tính doanh số bán trong ngày
- Tính lãi
- Tính hàng tồn
- Tính chi phí trong ngày

4 việc này trong marco có tách riêng thành 4 đoạn
1. Nhờ các bạn cho giúp đoạn code hiện thông báo đang tính gì đó. Ví dụ khi đang tính lãi thì hiện thông báo "Đang tính lãi"

2. Mình có đoạn code này khi chạy thấy mất thời gian, vì dữ liệu của mình gần 50 nghìn dòng. Ý nghĩa đoạn này: tìm những dòng ở cột thứ 5 có giá trị là 70 thì xóa dòng đó (dòng thứ 2 trở đi)

i = 1
Do While Cells(i + 1, 5) <> ""
If Cells(i + 1, 4) = "70" Then
Rows(i).Select
Selection.Delete Shift:=xlUp
Else
i = i + 1
End If
Loop

Nhờ các bạn thay thế giúp mình đoạn code khác giúp máy chạy nhanh hơn

Cám ơn nhiều

Nếu có file thì dùng mảng xoá trong nháy mắt. Không có file thì đợi đến tết Công Gô nhá

 

[SA_DQ]

2. Mình có đoạn code này khi chạy thấy mất thời gian, vì dữ liệu của mình gần 50 nghìn dòng. Ý nghĩa đoạn này: tìm những dòng ở cột thứ 5 có giá trị là 70 thì xóa dòng đó (dòng thứ 2 trở đi)

i = 1
Do While Cells(i + 1, 5) <> ""
    If Cells(i + 1, 4) = "70" Then
        Rows(i).Select
        Selection.Delete Shift:=xlUp
    Else
        i = i + 1
   End If
Loop

Nhờ các bạn thay thế giúp mình đoạn code khác giúp máy chạy nhanh hơn

Bạn có thể làm theo hướng dẫn này, thử xem:

Thay vì duyệt tất cả các ô trong cột, bạn dùng fương thức FIND() trong các ô chứa dữ liệu trong cột đó (Rng)
Khi tìm thấy thì ghép dòng đó vô biến đã khai báo, như dRg
Lặp lại FINDNEXT() cho đến hết
Sau rốt, xóa vùng dRg đi là xong

Đại để là vầy:

 Dim Rng As Range, sRng As Range, dRg As Range
 Dim fAdd As String 

 Set Rng=Range([E1],[E65500].End(xlUp)
 Set sRng=Rng.Find("70",,xlFormulas, xlWhole)
 If Not sRng Is Nothing then
     fAdd= sRng.Address
    Do
           If dRg Is Nothing Then
               Set dRg = sRng.EntireRow
           else    
           . . . . 
           End If 
    Loop . . . . 

    If Not dRg Is Nothing Then dRg.Delete
 End If

 

[Quang_Hải]

Bạn có thể làm theo hướng dẫn này, thử xem:

Thay vì duyệt tất cả các ô trong cột, bạn dùng fương thức FIND() trong các ô chứa dữ liệu trong cột đó (Rng)
Khi tìm thấy thì ghép dòng đó vô biến đã khai báo, như dRg
Lặp lại FINDNEXT() cho đến hết
Sau rốt, xóa vùng dRg đi là xong

Đại để là vầy:

 Dim Rng As Range, sRng As Range, dRg As Range
 Dim fAdd As String 

 Set Rng=Range([E1],[E65500].End(xlUp)
 Set sRng=Rng.Find("70",,xlFormulas, xlWhole)
 If Not sRng Is Nothing then
     fAdd= sRng.Address
    Do
           If dRg Is Nothing Then
               Set dRg = sRng.EntireRow
           else    
           . . . . 
           End If 
    Loop . . . . 

    If Not dRg Is Nothing Then dRg.Delete
 End If

Bài này em lại nghĩ theo hướng dùng SpecialCells chọn hết ô rỗng và xoá 1 nhát đứt đuôi con nòng nọc

***********

Ôi nhầm mất rồi, tìm số 70 vậy mà đọc ra là tìm ô rỗng để xoá.

 

[sealand]

Phương án của bác Sa_DQ chắc chắn sẽ tăng tốc hơn nhiều.
Nhưng để tăng tốc hơn, ta nên đưa cột E vào mảng rồi rà dữ liệu để xác định toàn bộ các dòng có cột E=70.
Tiếp theo ta có thể mỗi nhát xóa được 30 dòng (Lệ thuộc vào phương pháp range trong VBA) chắc tốc độ khá hơn.

 

[thienthanvuive]

Mình gửi file đính kèm rồi, các bạn giúp mình với

Cám ơn

 

[Quang_Hải]

Mình gửi file đính kèm rồi, các bạn giúp mình với

Cám ơn

Bạn có thể nào gởi cái file dưới 50k không? Thấy file to quá ớn lắm.

 

[thienthanvuive]

Bạn có thể nào gởi cái file dưới 50k không? Thấy file to quá ớn lắm.

File mình gửi chỉ bằng 20% dữ liệu thực đang dùng thôi mà. Bạn có thể down về, sửa giúp mình code chạy thử rồi paste code lên đây mình copy về file của mình cũng được.
cám ơn nhiều

 

[Quang_Hải]

File mình gửi chỉ bằng 20% dữ liệu thực đang dùng thôi mà. Bạn có thể down về, sửa giúp mình code chạy thử rồi paste code lên đây mình copy về file của mình cũng được.
cám ơn nhiều

Làm tốn công tải file tốn dung lượng mà chẳng ra làm sao. Trong cột E toàn là rừng Text, lấy gì mà tìm được ô nào có giá trị là ="70"
Lỡ tải file rồi nên cũng nhắm mắt viết đại đoạn code đơn giản này, nhưng xoá nhanh lắm. 50 000 dòng mất có vài giây

Sub xoa()
Dim data(), res(1 To 65536, 1 To 19), i, j, k
With Sheets("Ton")
   data = .Range(.[E2], .[W65536].End(3)).Value
   For i = 1 To UBound(data)
      If Mid(data(i, 1), 15, 2) <> "70" Then
         k = k + 1
         For j = 1 To 19
            res(k, j) = data(i, j)
         Next
      End If
   Next
   .[E2:W65536].ClearContents
   .[E2].Resize(k, 19) = res
End With
End Sub

 

[MuaBuiRoi]

Chào các bạn

2. Mình có đoạn code này khi chạy thấy mất thời gian, vì dữ liệu của mình gần 50 nghìn dòng. Ý nghĩa đoạn này: tìm những dòng ở cột thứ 5 có giá trị là 70 thì xóa dòng đó (dòng thứ 2 trở đi)

Nhờ các bạn thay thế giúp mình đoạn code khác giúp máy chạy nhanh hơn

Cám ơn nhiều

xóa cả dòng thì dùng code này cho nhanh, chốc lát là xóa xong, code bỏ tui ấy mà - nên bạn tự kiểm tra cẩn thận trước khi xóa (nhớ copy dự trữ 1 file khác vì không thể undo)

Sub xoa_dong()
    Const x = "70"
    Dim M, a(), e, d As Long, v As Range, R As Range
    
    M = Application.Calculation
    On Error GoTo 1
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With Sheets("Ton")
        Set v = .Range(.[E2], .[E65530].End(xlUp))
        Set R = .[E65531]
    End With
    
    a = v.Value
    If Not IsArray(a) Then a = Array(a)
    Set v = v(1, 1)
    
    For Each e In a
        d = d + 1
        If Mid(e, 15, 2) = x Then Set R = Union(R, v.Offset(d - 1))
    Next e
    
    
    d = R.Cells.Count - 1
    If d > 0 Then
         R.Interior.Color = vbRed
        Application.ScreenUpdating = False
        If MsgBox("Ban co chac chan xoa " & d & " dong co cell thoa man dieu kien (mau do (RED)) khong?", _
           vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
                R.EntireRow.Delete
        Else
                R.Interior.ColorIndex = 0
        End If
    Else
        MsgBox "Khong co dong nao thoa man de xoa"
    End If
1:  Application.EnableEvents = True
    Application.Calculation = M
    Application.ScreenUpdating = True
End Sub

nếu vùng khác, she et khác thì thay lại chỗ này cho hợp lý

    With Sheets("Ton")
        Set v = .Range(.[E2], .[E65530].End(xlUp))
        Set R = .[E65531]
    End With

 

[Ba Tê]

Trợn con mắt xem cái Sub trong bài #1 như vầy:
[GPECODE=vb]Sub Xu_ly_ton()'Dien thong tin vao sheet Ton
i = 3
Sheets("Ton").Select


Do While Cells(i, 5) <> ""
If Cells(i, 5) <> "" Then
i = i + 1
End If
Loop
Range("A22").Select
Selection.AutoFill Destination:=Range("A2", "D" & i)


'Chuyen text thanh so trong sheet Ton
Range("N2", "U" & i).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Selection.NumberFormat = "#,##0"
Application.CutCopyMode = False

i = 1
Do While Cells(i + 1, 5) <> ""
If Cells(i + 1, 4) = "70" Then
Rows(i).Select
Selection.Delete Shift:=xlUp
Else
i = i + 1
End If
Loop


'Ton nhieu 1
Sheets("Ton").Select
Range("A:X").Sort Key1:=Range("N1"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("B2:w101").Select
Selection.Copy
Sheets("High Stock").Select
Range("C3").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False

'Ton nhieu 2
Sheets("Ton").Select
Range("A:X").Sort Key1:=Range("T1"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("B2:W101").Select
Selection.Copy
Sheets("High Stock").Select
Range("C107").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
End Sub[/GPECODE]
Hình như lại phải "gọt chân xỏ giày" nữa rồi.
1/ Gán các mã "gì đó vào cột B,C,D của sheet TON
2/ Lọc ra các dòng có cột D <> "70"
3/ Sort cái bảng mới này theo cột O (Tồn kho) từ lớn đến nhỏ Nếu là Tồn nhiều 1, theo cột U nếu là Tồn nhiều 2.
4/ Lấy 100 dòng đầu (Số tồn lớn top 100)
5/ Xóa hết các dòng từ 101 trở xuống.
Phải vậy hông ta???????????????????
Nếu vậy thì "quất" một phát một xem sao.
[GPECODE=vb]Public Sub GPEx()
Application.ScreenUpdating = False
Dim sArr(), tArr(), I As Long, J As Long, K As Long, Uida As String
With Sheets("Ton")
sArr() = .Range(.[E2], .[E2].End(xlDown)).Offset(, -4).Resize(, 23).Value2
End With
ReDim tArr(1 To UBound(sArr, 1), 1 To 23)
For I = 1 To UBound(sArr, 1)
If Mid(sArr(I, 15), 15, 2) <> "70" Then
K = K + 1: tArr(K, 1) = K
tArr(K, 2) = Mid(sArr(I, 5), 6, 2)
tArr(K, 3) = Mid(sArr(I, 5), 6, 4)
tArr(K, 4) = Mid(sArr(I, 5), 15, 2)
For J = 5 To 23
tArr(K, J) = sArr(I, J)
Next J
End If
Next I
With Sheets("Ton nhieu")
Uida = IIf(.[O1].Value = 1, "O3", "U3")
.[B3:B65000].Resize(, 23).ClearContents
.[B3].Resize(K, 23) = tArr
.[C3].Resize(K, 22).Sort Key1:=.Range(Uida), Order1:=xlDescending
.[B103:W65000].ClearContents
End With
Application.ScreenUpdating = True
End Sub[/GPECODE]
Dữ liệu trên 30.000 dòng, tôi xoá bớt chỉ còn đến dòng 200 cho nhẹ file.

 

[sealand]

Mình thấy Code này cũng cho tốc độ tương đối khá, thậm chí nhanh nữa với 50.000 dòng

Sub DelSelRow()
Dim Sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Sh = Worksheets.Add
With Sheet3.[A1:W50000]
.AutoFilter
.AutoFilter Field:=5, Criteria1:="<>*70_*"
.SpecialCells(xlCellTypeVisible).Copy Sh.[A1]
.AutoFilter
.Clear
End With
Sh.[A1].CurrentRegion.Copy Worksheets("Ton").[A1]
Sh.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Sh = Nothing
End Sub