đã sửa lại nhưng có một vấn đề chạy code hiện 10 % luôn rồi đến 100 %
chứ không phải 1% 2% 3%
sửa lại giúp mình với
Public Sub Thong_Ke_Ton_Kho()
Dim DL, Kq(), r As Long, rw As Long, c As Long, i, j, uB As Long
On Error Resume Next
frmProgBar.Show False
Call progress(1)
'NAP SO LIEU CUA SHEET1 VAO MANG DL, SAU DO SORT
'Nap so lieu cua sheet1 vao mang DL
DL = Sheet1.Range("A9", Sheet1.Range("E1000000").End(xlUp))
'Khai bao mang Kq
ReDim Kq(1 To 1, 1 To UBound(DL, 2))
'Sort mang DL theo Lot No
For r = 1 To UBound(DL)
For c = 1 To UBound(DL, 2)
Kq(1, c) = DL(r, c)
Next c
For rw = r + 1 To UBound(DL)
If Kq(1, 4) > DL(rw, 4) Then
For c = 1 To UBound(DL, 2)
Kq(1, c) = DL(rw, c)
DL(rw, c) = DL(r, c)
DL(r, c) = Kq(1, c)
Next c
End If
Next rw
Next r
Call progress(10)
Application.ScreenUpdating = False
'LOC VA DAN
'Xoa toan bo cac dong cua sheet13
Sheet13.UsedRange.ClearContents
j = 1
With Sheet8
'Quet vung dieu kien, nap vao J9 va K9
For r = 7 To .Range("U1000000").End(xlUp).Row
.Range("J9").Value = .Range("U" & r)
.Range("K9").Value = .Range("V" & r)
Sheet14.Range("A11:E120").ClearContents
ReDim Kq(1 To UBound(DL), 1 To UBound(DL, 2))
i = 0
'Loc DL theo J9
For rw = 1 To UBound(DL)
If DL(rw, 3) = .Range("J9") Then
i = i + 1
For c = 1 To UBound(DL, 2)
Kq(i, c) = DL(rw, c)
Next c
End If
If uB > 99 Then
If rw Mod 100 = 0 Then _
Call progress(10 + Int(80 * (rw - 7) / (rw - 6)) + Int(80 * rw / (rw - 6) / uB))
End If
Next rw
'Dan ket qua loc vao sheet14
Sheet14.Range("A11").Resize(i, UBound(Kq, 2)).Value = Kq
'Lay ket qua cua sheet8
Kq = .Range("A7", "AA56")
'Dan ket qua tu sheet8 vao sheet13
Sheet13.Range("A" & j + 1).Resize(UBound(Kq, 1), UBound(Kq, 2)).Value = Kq
j = j + UBound(Kq, 1)
Next r
End With
Sheet13.Range("A1:V1") = Sheet8.Range("A4:V4").Value
Sheet13.UsedRange.Font.ColorIndex = 0
Sheet13.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
Beep
Call progress(100)
Sheet15.Range("c6").AutoFilter
Sheet15.Range("c6").AutoFilter
Sheets("sheet3").UsedRange.AutoFilter Field:=3, Criteria1:="<>"
Sheet16.Range("K5").AutoFilter
Sheet16.Range("K5").AutoFilter
Sheets("HSK (2)").UsedRange.AutoFilter Field:=9, Criteria1:="<>"
End Sub
Private Sub progress(pctCompl As Long)
'Application.Wait (Now + TimeValue("0:00:01") / 1)
frmProgBar.lblText.Caption = pctCompl & "% Completed"
frmProgBar.lblProgBar.Width = Int(pctCompl * 2.5)
DoEvents
End Sub
