[THI] Tạo sổ TH NXT với tốc độ nhanh nhất, dữ liệu 65,532 dòng

[Nguyễn Duy Tuân]

Cuộc thi tạo sổ tổ hợp nhập xuất tồn trong Excel tốc độ nhanh nhất

MỤC ĐÍCH
Trao đổi học tập để cùng nâng cao trình độ lập trình VBA về tối ưu code chạy nhanh và rõ ràng.

ĐỐI TƯỢNG THAM GIA
Là tất cả các thành viên GPE từ thành viên thường đến các Admin của GPE
Tôi cũng tham gia. Thực tế tôi đã viết code lâu rồi để phục vụ công việc quản lý kho, bản thân thấy chạy khá nhanh nhưng vẫn tin nó chưa phải hoàn hảo.
Nếu code của ai tối ưu nhất hoặc rõ ràng nhất sẽ trình bày code và giải thích cặn kẽ kỹ thuật để làm được ra nó trong topic này để mọi người tham khảo và học hỏi.

GIẢI THƯỞNG
Giải thưởng là cho tất cả thành viên của diễn đàn GPE được các bài học tốt về lập trình VBA trong Excel trong việc làm sổ sách tổng hợp.

THỜI GIAN DỰ THI, GỬI BÀI VÀ CÔNG BỐ
Dự thi từ ngày 10/02/2014.
Bài gửi chậm nhất là 12hAM ngày 15/02/2014.
Thời gian công bố kết quả đánh giá 14h 17/02/2014
Tất cả các bài dự thi, kết quả đánh giá sẽ được upload lên trang đầu của topic này.

Các bạn nén file đáp án rồi gửi bài vào email:
duytuan@bluesofts.net hoặc email của một thành viên BQT GPE (tôi bổ sung sau)
(Tôi sẽ là người nộp sớm nhất không sợ copy của người khác )

ĐỀ BÀI:
Tôi cung cấp tập tin dữ liệu với 65,532 dòng cùng module chứa các hàm và thủ tục đo tốc tộ, cấu trúc lệnh.
Bảng dữ liệu:

Nếu các bạn thắc mắc về phương pháp lập sổ tôi sẽ giải thích bài sau
Cấu trúc code:
[GPECODE=vb]Sub DoThoiGian()
Dim T1@, T2@, Freq@, Overhead@
QueryPerformanceFrequency Freq
QueryPerformanceCounter T1
QueryPerformanceCounter T2
Overhead = T2 - T1
QueryPerformanceCounter T1

'Thủ tuc của bạn

LapSo 'Thủ tuc của bạn phải làm

'Kết thúc chạy, đo thời gian thực hiện
QueryPerformanceCounter T2
'Debug.Print (T2 - T1 - Overhead) / Freq * 1000; "milliseconds(ms)"
MsgBox "milliseconds(ms): " & (T2 - T1 - Overhead) / Freq * 1000
End Sub[/GPECODE]


DoThoiGian là thủ tục mẹ được gán vào nút lệnh "Thực hiện" trên bảng tính. Nội dung trong thủ tục này bạn không được sửa. Bạn cần phải tạo thủ tục LapSo để lập sổ tổng hợp NXT.

[GPECODE=vb]Sub LapSo()
'Code của bạn để tạo ra sổ
End Sub[/GPECODE]

Kết quả thực hiện phải ra được sổ có cấu trúc và dữ liệu như sau

Lưu ý, sổ mẫu đã được định dạng vì vậy bạn không cần viết code để định dạng để giảm các yếu tốt ảnh hưởng tới tốc độ của code.

(Nếu bạn không biết lập trình VBA có thể lập công thức Excel thông thường. Tuy nhiên nó có thể được dùng để so sánh giữa lập trình VBA "thiện chiến" thế nào với cách lập công thức Excel thông thường mà thôi).

[TIP]Hướng dẫn tính toán
Các thành viên lưu ý. Sheet "Setting" có thông tin về ngày lập sổ: Từ ngày...đến ngày với các name NGAY1, NGAY2. Điều kiện để lập sổ phải dựa vào thời gian và Loại_phieu

Lượng Tồn đầu = lượng nhập với ngày < NGAY1 - lượng xuất với ngày < NGAY1
Lượng Nhập trong kỳ = lượng nhập với ngày >= NGAY1 và ngày <= NGAY2
Lượng Xuất trong kỳ = lượng xuất với ngày >= NGAY1 và ngày <= NGAY2
Lượng tồn cuối = Lượng Tồn đầu + Lượng Nhập trong kỳ - Lượng Xuất trong kỳ

Tương tự khi tính giá trị...[/TIP]

TIÊU CHÍ ĐÁNH GIÁ
Tìm ra các code đạt tốc độ nhanh nhất. Các bài làm cố gắng trình bày dễ hiểu và kèm comment trong code để giải thích.
Tất cả các bài với các phương pháp khác nhau cũng sẽ đăng lên để chúng ta học được nhiều phương pháp từ đó có thể vận dụng linh hoạt trong các việc khác.

Xin nói trước với các bạn là ta có thể đánh giá ở mức tương đối. Tất cả các code sẽ chạy trên một máy tính. Excel sẽ được khởi động lại với mỗi code mới, mỗi code được chạy 3 lần rồi lấy tốc độ trung bình. Tất cả các bài dự thi được upload lên đây để tất cả mọi người tham khảo.

Với tinh thần cầu thị, tạo sân chơi chung cho mọi người tôi rất mong chúng ta cùng tham gia. Mong các thành viên đừng e ngại về trình độ của mình thế này thế khác, cứ xác định tham gia để học để biết mình đã làm được gì và cần cải tiến cái gì về lập trình VBA.

-----------------
Đã có bài tổng hợp kết quả test và các file có mã nguồn của các tác giả gửi. Các thành viên xem bài #175 để download.
-----------------

 

[vodoi2x]

Tôi thấy code vodoi2x cực kỳ nhanh, chưa kiểm tra kỹ, chỉ vừa kiểm tra kết quả tính toán, thì thấy có sót số liệu 1 dòng cuối:

With Range("KHO").Resize(Range("KHO").Rows.Count - 1, 1).[COLOR=#ff0000]Offset(, 1)[/COLOR]

Chắc là do sai sót khi gõ thôi, chứ code thì tuyệt rồi.

Là do chỗ này cứ lấn cấn việc đặt name KHO là có gồm dòng tiêu đề hay không có dòng tiêu đề đây, dẫn đến chỉnh đi chỉnh lại xót luôn (vì lo việc tổng độ có sao chăng , khi ta offset hay không nên offset)

 With Range("KHO").Resize(Range("KHO").Rows.Count - 1, 1)[B][COLOR="#FF0000"].Offset(, 1)[/COLOR][/B]

Hiện name KHO là bao hàm cả dòng tiêu đề (như chủ topic đặt từ đầu)
nên sửa thành như sau cho đúng đủ số dòng dữ liệu

 With Range("KHO").Resize(Range("KHO").Rows.Count - 1, 1)[B][COLOR="#0000FF"].Offset(1, 1)[/COLOR][/B]

 

[ptm0412]

Tôi áp dụng 2 việc của vodoi2x vào code của tôi:
- Dùng Value2
- Dùng 5 mảng data nguồn 1 cột thay vì 1 mảng 11 cột
- Giữ nguyên thuật toán (sửa 2 biến Date đều thành Long, cho khỏi ngộ ngộ.)

Sau đó so với code của vodoi2x "Dictionary only" bài mới nhất #156, thấy code của tôi luôn nhanh hơn code vodoi2x của lần chạy đầu tiên.
phương pháp test:
- Code vodoi2x: Xóa những gì liên quan đến 2 biến Run1K và Run1D, xem như không dùng đến dữ liệu đang lưu trữ, mỗi lần chạy là mỗi lần nạp, và chạy 10 lần lấy trung bình.
- Code của tôi cũng chạy 10 lần lấy trung bình
- Đóng excel, test lại 10 lần nữa.



Code:

Sub LapSo()
    Application.ScreenUpdating = False
    Dim ListArr(), sArrID(), TmpArr(), RArr(), sArrQty(), sArrAmt(), sArrDocType(), sArrDate()
    Dim Dic1 As Object, EndR As Long, ListCt As Long
    Dim DataCt As Long, ListEndR As Long, Date1 As Long, Date2 As Long
    Dim i As Long, j As Long, k As Long, Check As Double
    ListEndR = Sheet1.[A100].End(xlUp).Row
    Set Dic1 = CreateObject("Scripting.Dictionary")
    ''Lay danh muc vao mang
    ListArr = Sheet1.Range("A4:C" & ListEndR).Value2
    ListCt = UBound(ListArr, 1)
    ''Nap mang danh muc vao Dic
    For i = 1 To ListCt
        Dic1.Add ListArr(i, 1), i
    Next
    ''Xác dinh dong cuoi cua data va nap vao mang
    With Sheet20
    EndR = .Cells(4, 1).End(xlDown).Row
        sArrID = .Range("G4:G" & EndR).Value2
        sArrQty = .Range("H4:H" & EndR).Value2
        sArrAmt = .Range("K4:K" & EndR).Value2
        sArrDocType = .Range("J4:J" & EndR).Value2
        sArrDate = .Range("B4:B" & EndR).Value2
    End With
    DataCt = EndR - 3
    '' gan gia tri cho bien
    ReDim TmpArr(1 To ListCt, 1 To 7)
    Date1 = Sheet3.[B1]
    Date2 = Sheet3.[B2]
    ''Duyet mang Data
    For i = 1 To DataCt
            ' 'Xac dinh dong chua ma HH trong danh muc, gan vao cot 1 cua KQ tam
            j = Dic1.Item(sArrID(i, 1))
            TmpArr(j, 1) = j
        ''Neu ngay < ngay bat dau, tinh 2 cot ton dau
        If sArrDate(i, 1) < Date1 Then
            If sArrDocType(i, 1) = "N" Then
                ''Cong nhap
                TmpArr(j, 2) = TmpArr(j, 2) + sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) + sArrAmt(i, 1)
            Else
                ''Tru xuat
                TmpArr(j, 2) = TmpArr(j, 2) - sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) - sArrAmt(i, 1)
            End If
        ''Neu ngay trong khoang bao cao
        ElseIf sArrDate(i, 1) <= Date2 Then
            ''Neu loai chung tu là N, tinh 2 cot Nhap
            If sArrDocType(i, 1) = "N" Then
                TmpArr(j, 4) = TmpArr(j, 4) + sArrQty(i, 1)
                TmpArr(j, 5) = TmpArr(j, 5) + sArrAmt(i, 1)
            ''Neu loai chung tu la X, tinh 2 cot xuat
            Else
                TmpArr(j, 6) = TmpArr(j, 6) + sArrQty(i, 1)
                TmpArr(j, 7) = TmpArr(j, 7) + sArrAmt(i, 1)
            End If
        End If
    ''Ket thuc vong lap, Mang KQ tam co 12 dong
    Next
    ''Khai bao  Mang KQua
    ReDim RArr(1 To ListCt, 1 To 12)
    k = 0
    ''Duyet mang KQ tam
    For i = 1 To ListCt
            ''Kiem tra dong co du lieu
            Check = TmpArr(i, 2) + TmpArr(i, 3) + TmpArr(i, 4) + _
            TmpArr(i, 5) + TmpArr(i, 6) + TmpArr(i, 7)
        ''Neu co dulieu, them vao mang KQua
        If Check > 0 Then
            k = k + 1
            ''4 cot thong so Hang hoa
            RArr(k, 1) = k
            RArr(k, 2) = ListArr(i, 1)
            RArr(k, 3) = ListArr(i, 2)
            RArr(k, 4) = ListArr(i, 3)
            ''6 cot Ton, nhap, xuat
            For j = 5 To 10
               RArr(k, j) = TmpArr(i, j - 3)
            Next
            ''2 cot Ton cuoi
            RArr(k, 11) = RArr(k, 5) + RArr(k, 7) - RArr(k, 9)
            RArr(k, 12) = RArr(k, 6) + RArr(k, 8) - RArr(k, 10)
           
        End If
    Next
    '' Gan ket qua xuong sau khi xoa
    Sheet26.[B12].Resize(12, 12).ClearContents
    Sheet26.[B12].Resize(k, 12) = RArr
Set Dic1 = Nothing
Application.ScreenUpdating = True
End Sub

 

[ptm0412]

Là do chỗ này cứ lấn cấn việc đặt name KHO là có gồm dòng tiêu đề hay không có dòng tiêu đề đây, dẫn đến chỉnh đi chỉnh lại xót luôn (vì lo việc tổng độ có sao chăng , khi ta offset hay không nên offset)

Chính vì không muốn offset và resize nhiều, do Name đã đặt bao gồm tiêu đề, nên tôi không dùng cái name nào. Chỉ tìm dòng cuối chứa dữ liệu và gán vào mảng. kể cả mảng danh mục.

 

[Hai Lúa Miền Tây]

Trong các file đã nhận vẫn chưa ai làm bằng ADO với SQL có lẽ lý do tốc độ không bằng phương pháp khác. Tuy nhiên SQL là giải pháp tổng thể và linh hoạt trong trích lọc dữ liệu. Vậy nhờ anh Hai Lúa Miền Tây làm giúp bằng ADO để chúng ta có đầy đủ hơn các giải pháp của dạng bài toán liên quan đến CSDL, dù tốc độ có thể không nhanh bằng các dạng khác ở ví dụ này.

Đúng là bài toán này dùng ADO là gọn và uyển chuyển nhất, tuy nhiên tốc độ so với những cách khác ở trên thì rất hạn chế. Cách ADO so với cách của anh vodoi2x thì ADO sẽ cho thời gian chậm hơn gấp 20 lần. Topic này đưa ra nhằm tìm cách giải quyết với thời gian nhanh nhất. Xét thấy ADO không có được ưu điểm về tốc độ cho bài toán này nên em đành theo dõi và học hỏi thêm từ những cách khác.

 

[vodoi2x]

Chính vì không muốn offset và resize nhiều, do Name đã đặt bao gồm tiêu đề, nên tôi không dùng cái name nào. Chỉ tìm dòng cuối chứa dữ liệu và gán vào mảng. kể cả mảng danh mục.

Offset resize, không làm giảm tốc độ đáng kể đâu ah,

Tôi áp dụng 2 việc của vodoi2x vào code của tôi:
- Dùng Value2
- Dùng 5 mảng data nguồn 1 cột thay vì 1 mảng 11 cột
- Giữ nguyên thuật toán (sửa 2 biến Date đều thành Long, cho khỏi ngộ ngộ.)

Sau đó so với code của vodoi2x "Dictionary only" bài mới nhất #156, thấy code của tôi luôn nhanh hơn code vodoi2x của lần chạy đầu tiên.
phương pháp test:
- Code vodoi2x: Xóa những gì liên quan đến 2 biến Run1K và Run1D, xem như không dùng đến dữ liệu đang lưu trữ, mỗi lần chạy là mỗi lần nạp, và chạy 10 lần lấy trung bình.
- Code của tôi cũng chạy 10 lần lấy trung bình
- Đóng excel, test lại 10 lần nữa.

đúng là giờ nhanh hơn rùi, nhờ chỉ sử dụng 1 Dictionary - và qua đó thấy vai trò của .Value2 cũng như Không đọc dữ liệu dư sẽ tăng tốc độ đáng kể trong bài toán topic này

Tuy vậy, PTM xem bổ sung việc lỗi xảy ra khi - Mã hàng không tồn tại trong "bảng danh mục" (sheet DM VLSPHH) nhưng lại có trong KHO

Vì dụ giờ ta có mã hàng mới là HH099 xuất hiện trong kho --> khi đó chương trình có lỗi -

VỚi đúng cơ sở DL này thì thuật toán này tốt đã giảm đi 1 DIC,

Tôi sẽ chuyển bài này của PTM sang sử dụng collection --> xem tốc độ thế nào có khi lại hay hơn phiên bản collection của tôi,

 

[Hai Lúa Miền Tây]

...
Tuy vậy, PTM xem bổ sung việc lỗi xảy ra khi - Mã hàng không tồn tại trong "bảng danh mục" (sheet DM VLSPHH) nhưng lại có trong KHO

Vì dụ giờ ta có mã hàng mới là HH099 xuất hiện trong kho --> khi đó chương trình có lỗi -
...

Nếu dùng ADO thì xử lý cái này rất đơn giản.

 

[vodoi2x]

Tôi sẽ chuyển bài này của PTM sang sử dụng collection --> xem tốc độ thế nào có khi lại hay hơn phiên bản collection của tôi,

Tôi đã thử chuyển Thời gian tính giảm đi khoảng 10% khi dùng collection so với dictionary - Tuy nhiên thời gian vẫn dài hơn (chậm) so với collection của vodoi2x ở bài 156

Code chuyển đây, và cũng đã sửa lỗi

Tuy vậy, PTM xem bổ sung việc lỗi xảy ra khi - Mã hàng không tồn tại trong "bảng danh mục" (sheet DM VLSPHH) nhưng lại có trong KHO

Vì dụ giờ ta có mã hàng mới là HH099 xuất hiện trong kho --> khi đó chương trình có lỗi -

code chuyển sang collection từ code gốc PTM bài 162

Sub LapSo()
    ''Code goc from PTM0412 sd Dictionary
    ''vodoi2x chinh sua , sua loi va chuyen sang collection 15.02.2014

    Application.ScreenUpdating = False
    Dim ListArr(), sArrID(), TmpArr(), RArr(), sArrQty(), sArrAmt(), sArrDocType(), sArrDate()
    Dim ColDM As Collection, EndR As Long, ListCt As Long
    Dim DataCt As Long, ListEndR As Long, Date1 As Long, Date2 As Long
    Dim i As Long, j As Long, k As Long, Check As Double
    ListEndR = Sheet1.[A100].End(xlUp).Row
    
    ''Lay danh muc vao mang
    ListArr = Sheet1.Range("A4:C" & ListEndR).Value2
    ListCt = UBound(ListArr, 1)
    
    Set ColDM = New Collection
    ''Nap mang danh muc vao Collection
    On Error Resume Next
    For i = 1 To ListCt
        ColDM.Add Item:=i, Key:=ListArr(i, 1)
    Next
    On Error GoTo 0
    
    ''Xác dinh dong cuoi cua data va nap vao mang
    With Sheet20
    EndR = .Cells(4, 1).End(xlDown).Row
        sArrID = .Range("G4:G" & EndR).Value2
        sArrQty = .Range("H4:H" & EndR).Value2
        sArrAmt = .Range("K4:K" & EndR).Value2
        sArrDocType = .Range("J4:J" & EndR).Value2
        sArrDate = .Range("B4:B" & EndR).Value2
    End With
    DataCt = EndR - 3
    '' gan gia tri cho bien
    ReDim TmpArr(1 To ListCt + 10, 1 To 7) ''10 so du phong Ma hang khong co trong danh muc
    Date1 = Sheet3.[B1]
    Date2 = Sheet3.[B2]
    Dim uB As Long
    uB = ListCt
    ''Duyet mang Data
    For i = 1 To DataCt
        If sArrDate(i, 1) <= Date2 Then
            ' 'Xac dinh dong chua ma HH trong danh muc, gan vao cot 1 cua KQ tam
            On Error Resume Next
            j = ColDM.Item(sArrID(i, 1))
            If Err.Number <> 0 Then
                On Error GoTo 0
                uB = uB + 1
                j = uB
                ColDM.Add Item:=j, Key:=sArrID(i, 1)
            Else
                On Error GoTo 0
            End If
            
            TmpArr(j, 1) = sArrID(i, 1) ''j
        ''Neu ngay < ngay bat dau, tinh 2 cot ton dau
        If sArrDate(i, 1) < Date1 Then
            If sArrDocType(i, 1) = "N" Then
                ''Cong nhap
                TmpArr(j, 2) = TmpArr(j, 2) + sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) + sArrAmt(i, 1)
            Else
                ''Tru xuat
                TmpArr(j, 2) = TmpArr(j, 2) - sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) - sArrAmt(i, 1)
            End If
        ''Neu ngay trong khoang bao cao
        Else   ''If sArrDate(i, 1) <= Date2 Then
            ''Neu loai chung tu là N, tinh 2 cot Nhap
            If sArrDocType(i, 1) = "N" Then
                TmpArr(j, 4) = TmpArr(j, 4) + sArrQty(i, 1)
                TmpArr(j, 5) = TmpArr(j, 5) + sArrAmt(i, 1)
            ''Neu loai chung tu la X, tinh 2 cot xuat
            Else
                TmpArr(j, 6) = TmpArr(j, 6) + sArrQty(i, 1)
                TmpArr(j, 7) = TmpArr(j, 7) + sArrAmt(i, 1)
            End If
        End If
      End If
    ''Ket thuc vong lap, Mang KQ tam co 12 dong
    Next
    ''Khai bao  Mang KQua
    ReDim RArr(1 To uB, 1 To 12)
    k = 0
    ''Duyet mang KQ tam
    For i = 1 To uB
            ''Kiem tra dong co du lieu
              Check = TmpArr(i, 2) + TmpArr(i, 3) + TmpArr(i, 4) + _
            TmpArr(i, 5) + TmpArr(i, 6) + TmpArr(i, 7)
        ''Neu co dulieu, them vao mang KQua
        If Check > 0 Then
            k = k + 1
            ''4 cot thong so Hang hoa
            RArr(k, 1) = k
            If i <= ListCt Then
                RArr(k, 2) = ListArr(i, 1)
                RArr(k, 3) = ListArr(i, 2)
                RArr(k, 4) = ListArr(i, 3)
            Else
                RArr(k, 2) = TmpArr(i, 1)
            End If
            ''6 cot Ton, nhap, xuat
            For j = 5 To 10
               RArr(k, j) = TmpArr(i, j - 3)
            Next
            ''2 cot Ton cuoi
            RArr(k, 11) = RArr(k, 5) + RArr(k, 7) - RArr(k, 9)
            RArr(k, 12) = RArr(k, 6) + RArr(k, 8) - RArr(k, 10)
           
        End If
    Next
    '' Gan ket qua xuong sau khi xoa
    Sheet26.[B12].Resize(12, 12).ClearContents
    Sheet26.[B12].Resize(k, 12) = RArr
    
    ''With Sheet26.[B12].Offset(k)
    ''    Union(.Offset(, 5), .Offset(, 7), .Offset(, 9), .Offset(, 11)).Formula = "=SUM(R[-" & k & "]C:R[-1]C)"
    ''End With
    
Set ColDM = Nothing
Application.ScreenUpdating = True
End Sub

(có thể chưa thật hiểu thuật toán gốc - nên có thể việc chuyển sang collection chưa hoàn hảo nên chưa phát huy được hết mặt mạnh code gốc, ---> nên mọi người cứ thử kiểm tra và check xem sao)

 

[Hai Lúa Miền Tây]

Tôi đã thử chuyển Thời gian tính giảm đi khoảng 10% khi dùng collection so với dictionary - Tuy nhiên thời gian vẫn dài hơn (chậm) so với collection của vodoi2x ở bài 156

Code chuyển đây, và cũng đã sửa lỗi


code chuyển sang collection từ code gốc PTM bài 162

Sub LapSo()
    ''Code goc from PTM0412 sd Dictionary
    ''vodoi2x chinh sua , sua loi va chuyen sang collection 15.02.2014

    Application.ScreenUpdating = False
    Dim ListArr(), sArrID(), TmpArr(), RArr(), sArrQty(), sArrAmt(), sArrDocType(), sArrDate()
    Dim ColDM As Collection, EndR As Long, ListCt As Long
    Dim DataCt As Long, ListEndR As Long, Date1 As Long, Date2 As Long
    Dim i As Long, j As Long, k As Long, Check As Double
    ListEndR = Sheet1.[A100].End(xlUp).Row
    
    ''Lay danh muc vao mang
    ListArr = Sheet1.Range("A4:C" & ListEndR).Value2
    ListCt = UBound(ListArr, 1)
    
    Set ColDM = New Collection
    ''Nap mang danh muc vao Collection
    On Error Resume Next
    For i = 1 To ListCt
        ColDM.Add Item:=i, Key:=ListArr(i, 1)
    Next
    On Error GoTo 0
    
    ''Xác dinh dong cuoi cua data va nap vao mang
    With Sheet20
    EndR = .Cells(4, 1).End(xlDown).Row
        sArrID = .Range("G4:G" & EndR).Value2
        sArrQty = .Range("H4:H" & EndR).Value2
        sArrAmt = .Range("K4:K" & EndR).Value2
        sArrDocType = .Range("J4:J" & EndR).Value2
        sArrDate = .Range("B4:B" & EndR).Value2
    End With
    DataCt = EndR - 3
    '' gan gia tri cho bien
    ReDim TmpArr(1 To ListCt + 10, 1 To 7) '10 so du phong Ma hang khong co trong danh muc
    Date1 = Sheet3.[B1]
    Date2 = Sheet3.[B2]
    Dim uB As Long
    uB = ListCt
    ''Duyet mang Data
    For i = 1 To DataCt
        If sArrDate(i, 1) <= Date2 Then
            ' 'Xac dinh dong chua ma HH trong danh muc, gan vao cot 1 cua KQ tam
            On Error Resume Next
            j = ColDM.Item(sArrID(i, 1))
            If Err.Number <> 0 Then
                On Error GoTo 0
                uB = uB + 1
                j = uB
                ColDM.Add Item:=j, Key:=sArrID(i, 1)
            Else
                On Error GoTo 0
            End If
            
            TmpArr(j, 1) = sArrID(i, 1) 'j
        ''Neu ngay < ngay bat dau, tinh 2 cot ton dau
        If sArrDate(i, 1) < Date1 Then
            If sArrDocType(i, 1) = "N" Then
                ''Cong nhap
                TmpArr(j, 2) = TmpArr(j, 2) + sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) + sArrAmt(i, 1)
            Else
                ''Tru xuat
                TmpArr(j, 2) = TmpArr(j, 2) - sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) - sArrAmt(i, 1)
            End If
        ''Neu ngay trong khoang bao cao
        Else   ''If sArrDate(i, 1) <= Date2 Then
            ''Neu loai chung tu là N, tinh 2 cot Nhap
            If sArrDocType(i, 1) = "N" Then
                TmpArr(j, 4) = TmpArr(j, 4) + sArrQty(i, 1)
                TmpArr(j, 5) = TmpArr(j, 5) + sArrAmt(i, 1)
            ''Neu loai chung tu la X, tinh 2 cot xuat
            Else
                TmpArr(j, 6) = TmpArr(j, 6) + sArrQty(i, 1)
                TmpArr(j, 7) = TmpArr(j, 7) + sArrAmt(i, 1)
            End If
        End If
      End If
    ''Ket thuc vong lap, Mang KQ tam co 12 dong
    Next
    ''Khai bao  Mang KQua
    ReDim RArr(1 To uB, 1 To 12)
    k = 0
    ''Duyet mang KQ tam
    For i = 1 To uB
            ''Kiem tra dong co du lieu
              Check = TmpArr(i, 2) + TmpArr(i, 3) + TmpArr(i, 4) + _
            TmpArr(i, 5) + TmpArr(i, 6) + TmpArr(i, 7)
        ''Neu co dulieu, them vao mang KQua
        If Check > 0 Then
            k = k + 1
            ''4 cot thong so Hang hoa
            RArr(k, 1) = k
            If i <= ListCt Then
                RArr(k, 2) = ListArr(i, 1)
                RArr(k, 3) = ListArr(i, 2)
                RArr(k, 4) = ListArr(i, 3)
            Else
                RArr(k, 2) = TmpArr(i, 1)
            End If
            ''6 cot Ton, nhap, xuat
            For j = 5 To 10
               RArr(k, j) = TmpArr(i, j - 3)
            Next
            ''2 cot Ton cuoi
            RArr(k, 11) = RArr(k, 5) + RArr(k, 7) - RArr(k, 9)
            RArr(k, 12) = RArr(k, 6) + RArr(k, 8) - RArr(k, 10)
           
        End If
    Next
    '' Gan ket qua xuong sau khi xoa
    Sheet26.[B12].Resize(12, 12).ClearContents
    Sheet26.[B12].Resize(k, 12) = RArr
    
    'With Sheet26.[B12].Offset(k)
    '    Union(.Offset(, 5), .Offset(, 7), .Offset(, 9), .Offset(, 11)).Formula = "=SUM(R[-" & k & "]C:R[-1]C)"
    'End With
    
Set ColDM = Nothing
Application.ScreenUpdating = True
End Sub

(có thể chưa thật hiểu thuật toán gốc - nên có thể việc chuyển sang collection chưa hoàn hảo nên chưa phát huy được hết mặt mạnh code gốc, ---> nên mọi người cứ thử kiểm tra và check xem sao)

Máy em chạy lỗi Run-time error '13' tại dòng

ColDM.Add Item:=j, Key:=sArrID(i, 1)

 

[vodoi2x]

Máy em chạy lỗi Run-time error '13' tại dòng

Vậy thử down file sau về thử xem có còn bị lỗi đó không?

 

[Hoàng Trọng Nghĩa]

Thử với Collection!

Thay vì dùng Dictionary, tôi dùng Collection để thay thế (bài tôi gửi Anh Tuân tôi dùng Dictionary).

[COLOR=#0000ff]Function [/COLOR][COLOR=#008000]Exists[/COLOR][COLOR=#0000ff](ByRef Collect As [/COLOR][COLOR=#ff0000]Collection[/COLOR][COLOR=#0000ff], ByVal sKey As String) As Boolean[/COLOR]
[COLOR=#0000ff]    Dim lCheck As Long[/COLOR]
[COLOR=#0000ff]    On Error Resume Next[/COLOR]
[COLOR=#0000ff]    lCheck = VarType(Collect.Item(sKey))[/COLOR]
[COLOR=#0000ff]    If Err.Number = 0 Then[/COLOR]
[COLOR=#0000ff]        Exists = True[/COLOR]
[COLOR=#0000ff]    Else[/COLOR]
[COLOR=#0000ff]        Exists = False[/COLOR]
[COLOR=#0000ff]    End If[/COLOR]
[COLOR=#0000ff]End Function[/COLOR]

[GPECODE=vb]


Sub LapSo()
Static ArrData, LastRow 'moi cap nhat
If Not IsArray(ArrData) Then
Dim RowCount As Long
''Du cho thoi gian co cham may cung phai dung thu tuc kiem tra AutoFilterMode,
''neu khong co hang nay va sheet co Filter thi se co kha nang bien LastRow
''bi mat hang:
If Sheets("KHO").AutoFilterMode Then Sheets("KHO").AutoFilterMode = False
''Luong truoc viec "Over Float" cua sheet khi "can dong", dung End la khong duoc,
''dong thoi du cho Excel 2003 hay 2013 van dung duoc: (moi nhan dinh them)
RowCount = Range("A:A").Rows.Count
If Sheets("KHO").Range("A" & RowCount) = "" Then
LastRow = Sheets("KHO").Range("A" & RowCount).End(xlUp).Row + 1
Else
LastRow = RowCount
End If
''Luong truoc kha nang du lieu tai KHO chua nhap du lieu:
If LastRow - 1 <= 3 Then
MsgBox "Tai sheet 'KHO' chua co du lieu nao!"
Exit Sub
End If
''Nen gan array bang mang 1 chieu theo cot vi vay no
''se xu ly rat nhanh (mau chot cua van de nhanh cham),
''uu diem cua no la ban co the sap xep vi tri cot ngay tu dau:
ReDim ArrData(1 To 5)
With Sheets("KHO").Range("B4:B" & LastRow)
ArrData(1) = .Offset(, 5) 'MA_VLSPHH
ArrData(2) = .Offset(, 6) 'SLG
ArrData(3) = .Offset(, 9) 'THANH_TIEN
ArrData(4) = .Offset(, 8) 'LOAI_PHIEU
ArrData(5) = .Value 'NGAY_CT
End With
End If
''Nen dat cac bien sau Exit Sub de khoi phai giai phong bien:
Dim Collect As New Collection
Dim c As Long, r As Long, n As Long
Dim IDProductColumn As Range, IDProduct As Range
Dim ArrReport(), ArrToTal(3 To 12)
Dim CondDate As Date, FromDate As Date, ToDate As Date
''Nhan gia tri ngay tai sheet SETTING:
FromDate = Range("NGAY1").Value
ToDate = Range("NGAY2").Value
''Tieu de cho hang TONG CONG:
ArrToTal(3) = "T" & ChrW(7892) & "NG C" & ChrW(7896) & "NG:"
''Tao san cot MaSanPham de phuc vu cho Find method:
Set IDProductColumn = Range(Sheets("DM VLSPHH").Range("A3"), Sheets("DM VLSPHH").Range("A" & LastRow).End(xlUp))
Dim ItmID As String
Dim Index As Long, m As Long
Dim General(), GetID(), Balance_In_Out(1 To 3), Quantity_Amount(1 To 2)
For r = 1 To UBound(ArrData(1))
''Ma san pham theo tung record:
ItmID = ArrData(1)(r, 1)
''Ngay de tinh dieu kien:
CondDate = ArrData(5)(r, 1)
If ItmID = "" Or CondDate > ToDate Then GoTo NextR
If Exists(Collect, ItmID) Then
''Truy van index tu Collect:
Index = Collect.Item(ItmID)
''Neu ngay dieu kien nho hon ngay bat dau:
If CondDate < FromDate Then
''Neu cot Loai_Phieu la Nhap:
If ArrData(4)(r, 1) = "N" Then
General(Index)(1)(1) = General(Index)(1)(1) + ArrData(2)(r, 1) 'SLG
General(Index)(1)(2) = General(Index)(1)(2) + ArrData(3)(r, 1) 'THANH_TIEN
''Neu la Xuat:
Else
General(Index)(1)(1) = General(Index)(1)(1) - ArrData(2)(r, 1) 'SLG
General(Index)(1)(2) = General(Index)(1)(2) - ArrData(3)(r, 1) 'THANH_TIEN
End If
''Neu ngay dieu kien nho hon hoac ban ngay ket thuc:
ElseIf CondDate <= ToDate Then
If ArrData(4)(r, 1) = "N" Then
General(Index)(2)(1) = General(Index)(2)(1) + ArrData(2)(r, 1) 'SLG
General(Index)(2)(2) = General(Index)(2)(2) + ArrData(3)(r, 1) 'THANH_TIEN
Else
General(Index)(3)(1) = General(Index)(3)(1) + ArrData(2)(r, 1) 'SLG
General(Index)(3)(2) = General(Index)(3)(2) + ArrData(3)(r, 1) 'THANH_TIEN
End If
End If
Else
n = n + 1
ReDim Preserve GetID(1 To n), General(1 To n)
Collect.Add n, ItmID
GetID(n) = ItmID
If CondDate < FromDate Then
If ArrData(4)(r, 1) = "N" Then
Quantity_Amount(1) = ArrData(2)(r, 1) 'SLG
Quantity_Amount(2) = ArrData(3)(r, 1) 'THANH_TIEN
Else
Quantity_Amount(1) = -ArrData(2)(r, 1) 'SLG
Quantity_Amount(2) = -ArrData(3)(r, 1) 'THANH_TIEN
End If
''Gan phan tu nay,
Balance_In_Out(1) = Quantity_Amount
''nhung khong the bo qua buoc duoi nay,
''neu khong se bi loi type mismatch(13)
''khi Exists=True hoat dong:
Quantity_Amount(1) = Empty
Quantity_Amount(2) = Empty
Balance_In_Out(2) = Quantity_Amount
Balance_In_Out(3) = Quantity_Amount
ElseIf CondDate <= ToDate Then
Quantity_Amount(1) = ArrData(2)(r, 1) 'SLG
Quantity_Amount(2) = ArrData(3)(r, 1) 'THANH_TIEN
If ArrData(4)(r, 1) = "N" Then
Balance_In_Out(2) = Quantity_Amount
Quantity_Amount(1) = Empty
Quantity_Amount(2) = Empty
Balance_In_Out(1) = Quantity_Amount
Balance_In_Out(3) = Quantity_Amount
Else
Balance_In_Out(3) = Quantity_Amount
Quantity_Amount(1) = Empty
Quantity_Amount(2) = Empty
Balance_In_Out(1) = Quantity_Amount
Balance_In_Out(2) = Quantity_Amount
End If
End If
''Array 'General' nhan cac array trong array:
General(n) = Balance_In_Out
End If
NextR:
Next
Dim x As Byte, y As Byte, z As Byte
''Xu ly mang cuoi cung de xuat du lieu ra sheet:
ReDim ArrReport(1 To n, 1 To 12)
For r = 1 To n
ArrReport(r, 1) = r 'STT
ArrReport(r, 2) = GetID(r) 'MA
''Tim trong sheet DM VLSPHH de gan ten va don vi tinh:
Set IDProduct = IDProductColumn.Find(What:=GetID(r), LookIn:=xlFormulas, LookAt:=xlWhole)
If Not IDProduct Is Nothing Then
ArrReport(r, 3) = IDProduct.Offset(, 1) 'TEN
ArrReport(r, 4) = IDProduct.Offset(, 2) 'DVT
End If
ArrReport(r, 5) = General(r)(1)(1) 'SL_TON
ArrReport(r, 6) = General(r)(1)(2) 'TT_TON
ArrReport(r, 7) = General(r)(2)(1) 'SL_NHAP
ArrReport(r, 8) = General(r)(2)(2) 'TT_NHAP
ArrReport(r, 9) = General(r)(3)(1) 'SL_XUAT
ArrReport(r, 10) = General(r)(3)(2) 'TT_XUAT
ArrReport(r, 11) = ArrReport(r, 5) + ArrReport(r, 7) - ArrReport(r, 9) 'SL_TONCUOI
ArrReport(r, 12) = ArrReport(r, 6) + ArrReport(r, 8) - ArrReport(r, 10) 'TT_TONCUOI
''Dung cho viec total:
For c = 5 To 12
ArrToTal(c) = ArrToTal(c) + ArrReport(r, c)
Next
Next
''Xoa noi dung bieu mau cua sheet THNXT.
''Nen co dinh truoc bieu mau co so hang
''khong thay doi, se xu ly sau neu so hang phat sinh:
Sheets("THNXT").Range("B12:M24").ClearContents
''Le ra phai co che do 'co-gian' bieu mau, neu n > 13 thi
''phai xu ly bieu mau truoc khi gan array vao:
Sheets("THNXT").Range("B12").Resize(n, 12) = ArrReport
''Neu xu ly thi nen dat mot name tai ô có chu CONG,
''Boi khi insert hay delete hang name deu chay theo!
''Tam thoi gan theo dia chi co dinh:
Sheets("THNXT").Range("D24:M24") = ArrToTal
End Sub[/GPECODE]

- Dùng 5 mảng data nguồn 1 cột thay vì 1 mảng 11 cột
- Giữ nguyên thuật toán (sửa 2 biến Date đều thành Long, cho khỏi ngộ ngộ.)

Cái vụ màu đỏ em đã sử dụng từ rất lâu rồi ạ và thuật toán Mảng trong Mảng cũng thú vị và rất nhanh đấy Sư phụ ạ. Riêng cái Collection (có thể nó có ở đâu đó trên diễn đàn mà tôi chưa thấy) thì mới biết từ bài của Vodoi2x (trước đây học lóm của Thầy ndu96081631 chiêu Dictionary). Cám ơn Vodoi2x nhé! Giờ thì mình có thể học lóm thêm chiêu này!

 

[Lê Duy Thương]

mình không biết nhiều về code nên chỉ ăn gian thôi .ec ec

 

[Hoàng Trọng Nghĩa]

mình không biết nhiều về code nên chỉ ăn gian thôi .ec ec

Nếu code khai báo biến với Static hoặc Public thì người ta cũng ăn gian ở các lần sau như cậu thôi, bởi lần đầu code cậu tạo Pivot, lần sau cậu đã có nó và thực hiện lệnh copy (cái này cậu ăn gian hơn tí hihihi)!

---------------------------------------------------------------------
Test với Dictionary và Collection thì trên máy tính của tôi Dict vẫn nhanh hơn Coll với vòng lặp 300.000 lần, nhưng nếu hơn nữa thì thằng Coll chạy ăn đứt thằng Dict!

Sub DictTest()
    Dim i As Long
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To 300000
        Dict.Add "Nghia" & i, i
    Next
End Sub


Sub CollTest()
    Dim i As Long
    Dim Collect As New Collection
    For i = 1 To 300000
        Collect.Add i, "Nghia" & i
    Next
End Sub

------------------------------------------------------------------
Đúng như tôi nghĩ, Collection đã được admin levanduyet giới thiệu tại đây:

http://www.giaiphapexcel.com/forum/...y-các-giá-trị-không-trùng&p=235231#post235231

 

[Lê Duy Thương]

Nếu code khai báo biến với Static hoặc Public thì người ta cũng ăn gian ở các lần sau như cậu thôi, bởi lần đầu code cậu tạo Pivot, lần sau cậu đã có nó và thực hiện lệnh copy (cái này cậu ăn gian hơn tí hihihi)!

---------------------------------------------------------------------
Test với Dictionary và Collection thì trên máy tính của tôi Dict vẫn nhanh hơn Coll, nhưng nếu hơn nữa thì thằng Coll chạy ăn đứt thằng Dict!

Sub DictTest()
    Dim i As Long
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To 300000
        Dict.Add "Nghia" & i, i
    Next
End Sub


Sub CollTest()
    Dim i As Long
    Dim Collect As New Collection
    For i = 1 To 300000
        Collect.Add i, "Nghia" & i
    Next
End Sub

------------------------------------------------------------------
Đúng như tôi nghĩ, Collection đã được admin levanduyet giới thiệu tại đây:

http://www.giaiphapexcel.com/forum/...y-các-giá-trị-không-trùng&p=235231#post235231

nếu dữ liệu it thì dic nhanh hơn, dữ liệu nhiều thì collection nhanh hơn
trước đây tôi cũng có sử dụng 1 lần vọc collection.để lọc duy nhất.nhưng ko nhanh bằng dictionary
http://www.giaiphapexcel.com/forum/...lọc-duy-nhất-từ-danh-sách&p=524518#post524518

 

[Hoàng Trọng Nghĩa]

Tôi ngồi ngẫm nghĩ và nghiệm ra như thế này, với biến mảng động, thay vì ta khai báo với Static trong thủ tục:

Sub TestStatic()
    [COLOR=#ff0000][B]Static [/B][/COLOR]ArrData
    If Not IsArray(ArrData) Then
        '....
    End If
End Sub

Thì ta nên thực hiện biến này với khai báo là Public:

[COLOR=#0000ff][B]Public [/B][/COLOR]ArrData


Sub TestPublic()
    If Not IsArray(ArrData) Then
        '....
    End If
End Sub

Một lý do hết sức đơn giản là, khi dữ liệu mà mảng ArrData được gán thay đổi, cụ thể trong bài này là sheet KHO vì lý do gì đó nhập thêm hay bớt ra (thông thường cơ sở dữ liệu người ta thường nhập trên Form) thì ta chỉ việc dùng thủ tục này để giải phóng biến, thay vì dùng biến Boolean để check (dư ra biến Boolean này):

Sub ClearVariable()
    [COLOR=#008000][B]ArrData = Null[/B][/COLOR]
End Sub

Mặc dù bài mà Anh Nguyễn Duy Tuân đưa ra tương đối dễ, nhưng học hỏi và suy luận được rất nhiều thứ!

 

[Nguyễn Duy Tuân]

Tổng kết cuộc thi viết code đạt tốc độ nhanh nhất sổ tổng hợp nhập xuất tồn

Tổng kết cuộc thi viết code đạt tốc độ nhanh nhất bài lập sổ tổng hợp nhập xuất tồn trong VBA.
Cuộc thi phát động vào sáng ngày 10-02-2014, hạn cuối gửi bài 12hAM ngày 15/02/2014.

Qua 6 ngày vừa qua có thể thấy có rất nhiều thành viên quan tâm và được thể hiện qua lượng người xem > 3000. Được các thành viên có kinh nghiệm tốt về VBA đã nhiệt tình tham gia trao đổi, gửi bài như: SA_DQ, HYen17, ChanhTQ@, Ba Tê, Hoàng Trọng Nghĩa, Lê Duy Thương, Hai Lúa Miền Tây, ptm0412, dhn46, Nguyễn Duy Tuân, Vodoi2x.

Việc đánh giá các bài gửi bằng phương pháp như sau

1. Tất cả phải chạy trên cùng một máy tính
2. Tắt tất cả các ứng dụng đang chạy, các chương trình thường trú cũng tắt đi nếu không liên quan đến Windows để giảm những tác động đến Windows và Excel.
3. Một bài thi phải được test theo quy trình như sau
b1. Tắt Excel (nếu đang mở)->Mở Excel -->đảm bảo môi trường "sạch"
b2. Mở file Excel cần đo thời gian. Hãy đợi một lúc đảm bảo Excel đã thực hiện các công việc của nó xong. Hãy nhấn CTRL+ALT+DEL để mở "Task Manager", trong tab "Processes" đảm bảo dòng có EXCEL.EXE, CPU và Memory đang ở con số ổn định (không thay đổi liên tục).
Sửa lại thủ tục "DoThoiGian" để tự tính trung bình 3 lần chạy như sau:
[GPECODE=vb]
Sub DoThoiGian()
Dim T1@, T2@, Freq@, Overhead@, I&, T(2)
QueryPerformanceFrequency Freq
QueryPerformanceCounter T1
QueryPerformanceCounter T2
Overhead = T2 - T1
Debug.Print ActiveWorkbook.Name
For I = 0 To 2
QueryPerformanceCounter T1

'Thu tuc cua ban

LapSo 'Thu tuc ban phai lam

'Ket thuc chay thu tuc, nhan thoi gian ket thuc
QueryPerformanceCounter T2
T(I) = Round((T2 - T1 - Overhead) / Freq * 1000, 0)
Debug.Print "Lan " & I + 1, T(I); "milliseconds(ms)"
Next I
Debug.Print "Toc do trung binh: "; Round((T(0) + T(1) + T(2)) / 3, 0); "milliseconds(ms)"
MsgBox "Toc do trung binh: " & Round((T(0) + T(1) + T(2)) / 3, 0) & " milliseconds(ms)", vbInformation, "Code da duoc chay 3 lan"
End Sub
[/GPECODE]
b3. Nhấn nút "Thực Hiện" tại sheet "THNXT" và ghi nhận thời gian thực hiện.

Đến code của bài dự thi khác lại lập lại từ b1.

Kết quả do tôi test như sau.
Cấu hình phần cứng và phần mềm của máy tính test

Microsoft Excel 2010 Professional Plus 32-bit.

Kết quả thu được như sau:

Với kết quả trên chúng ta thấy ngay anh Vodoi2x là người có code chạy nhanh nhất với ví dụ dùng Collection, tốc độ đạt 250 mili giây. Xin cảm ơn và chúc mừng anh.

Đánh giá chung các bài của các tác giả:
Tất cả các bài thi tốc độ đều < 1000 mili giây vì vậy đều có thể được coi tốc độ nhanh.
Các tác giả Ba Tê, Hoàng Trọng Nghĩa, dhn46 dùng Array và Dictionary để nạp danh sách duy nhất. Tốc độ khá nhanh, chêch lệch nhau không nhiều.
Bác HYen17 thì viết VBA kết hợp với hàm Excel là SumIf chạy cũng rất nhanh, tuy nhiên các thành viên chờ bác sửa lại code về mã danh mục thì không thấy bác viết tiếp. Hy vọng bác bổ sung tiếp trong topic này.
Anh Lê Duy Thương dùng Pivot cũng rất tốt. Tuy nhiên để đánh giá ký chút ta phải tính cả lúc tạo Pivot. Nếu trong thực tế sử dụng ta chỉ phải tạo Pivot nếu chưa từng tạo nó còn lần thứ 2 trở đi không phải tạo thì Pivot có lẽ là tốc độ nhanh nhất. Nếu nếu file Excel lưu Pivot các bạn nên chú ý tới dung lượng của file, tốc độ mở file Excel vì có thể sẽ nặng và chậm.
Anh Vodoi2x đã đưa cả 2 cách Dictionary và Collection kết hợp với Array. Ví dụ Dictionary tốc độ cũng không bằng Collection. Xem qua thì hình như code trong ví dụ Collection có giải thuật khác? Cá nhân em đánh giá với yêu cầu ví dụ này thì nếu chỉ là Collection thì nó không phải yếu tố làm cho code chạy nhanh? Các yếu tố quyết định làm cho code của anh Vodoi2x chạy nhanh nhất chính là chuyển dùng Value2 thay cho Value, chuyển Range.Value2 sang array, array đóng vai trò là nguồn dữ liệu, được dùng để phân tích và tính toán trong vòng lặp.

Bài của tôi - Nguyễn Duy Tuân đã gửi trang đầu đạt tốc độ thấp nhất (hơn 2000 mili giây). Đạt giải khuyến khích . Tuy nhiên sau khi lấy kinh nghiệm bài anh Vodoi2x chuyển Range sang Array làm nguồn, Value->Value2, giữ nguyên thuật toán tốc độ đạt 299 mili giây (kém 50 mili giây so với bài Vodoi2x). Điều đặc biệt trong code của tôi chỉ dùng Array (không dùng Dictionary, Collection). Tôi đang nghi ngờ rằng, code của anh Vodoi2x nhanh hơn của tôi là do thuật toán hoán đổi mảng chứ không phải do dùng Collection?

Nhiều người đã thí nghiệm Collection nhanh hơn Dictionary nên tôi lấy Collection so sánh với Array với bài test: nạp danh sách, kiểm tra mã tồn tài và nạp tiếp.
[GPECODE=vb]
Sub DoThoiGianColl_Array()
Dim T1@, T2@, Freq@, Overhead@
Dim TimeColl, TimeArray
QueryPerformanceFrequency Freq
QueryPerformanceCounter T1
QueryPerformanceCounter T2
Overhead = T2 - T1
'Debug.Print "Test Collection"
QueryPerformanceCounter T1
TestCollection 'Thu tuc ban phai lam
QueryPerformanceCounter T2
TimeColl = (T2 - T1 - Overhead) / Freq * 1000 '; "milliseconds(ms)"
'Test Array
'Debug.Print "Test Array"
QueryPerformanceCounter T1
TestArray 'Thu tuc ban phai lam
QueryPerformanceCounter T2
TimeArray = (T2 - T1 - Overhead) / Freq * 1000 '; "milliseconds(ms)"
'Ket thuc chay thu tuc, nhan thoi gian ket thuc
MsgBox "Toc do cua Collection & Array trong viec them phan tu va kiem tra su ton tai cua phan tu: " & Chr(13) & _
"Collection: " & Round(TimeColl, 0) & Chr(13) & _
"Array: " & Round(TimeArray, 0), vbInformation, "Don vi do milliseconds(ms)"
End Sub

Sub TestCollection()
Dim Coll As New Collection
Dim I&, Item
For I = 1 To 50000
Coll.Add CStr(I), CStr(I)
Next I
For I = 1 To 100
Item = "25000"
If Not CollExist(Item, Coll) Then
Coll.Add Item, Item
End If
Next I
Set Coll = Nothing
End Sub

Function CollExist(Item, Colls As Collection) As Boolean
On Error GoTo lbEndFunc
Colls.Item (Item)
CollExist = True
Exit Function
lbEndFunc:
CollExist = False
End Function

Sub TestArray()
Dim Coll()
Dim I&, Item
For I = 1 To 50000
ReDim Preserve Coll(I - 1)
Coll(I - 1) = CStr(I)
Next I
For I = 1 To 100
Item = "25000"
If Not ItemExists(Item, Coll) Then
ReDim Preserve Coll(I - 1)
Coll(I - 1) = CStr(I)
End If
Next I
End Sub
'Ham kiem tra doi tuong co trong mang hay khong
Function ItemExists(Item, Arr()) As Long
Dim I&
ItemExists = -1
On Error GoTo lbDone
If Not IsArray(Arr) Then Exit Function
'Tim tu phan tu cuoi cung cua mang len dau se dat toc do tim nhanh neu du lieu nguon duoc sap xep tang dan
For I = UBound(Arr) To LBound(Arr) Step -1
If Arr(I) = Item Then
ItemExists = I
Exit For
End If
Next I
lbDone:
'Loi xay ra neu
End Function
[/GPECODE]

Chạy thủ tục "DoThoiGianColl_Array" thì thấy Collection: 667, Array: 107. Vậy Array nhanh hơn Collection rất nhiều. Với bài toán mà yêu cầu nạp danh sách duy nhất thì ta nên dùng Array thuần túy là được rồi. Việc kiểm tra Item có tồn tại trong danh sách hay không ta tự viết tốc độ sẽ nhanh hơn ở vấn đề như sau. Nếu danh sách Mã hàng hóa trong sổ KHO sắp xếp tăng dần khi đó các mã nạp trong mảng có danh sách duy nhất cũng tăng dần. Vậy khi kiểm tra một mã theo thứ tự trong sổ KHO, hàm ItemExists tìm từ dưới lên trên nó sẽ thấy ngay bới 1 đến 2 vòng. Nếu theo kiểm tra ngầm định các hàm Dictionary.Exists() nếu tìm từ trên xuống dưới, khi số mã hàng nhiều việc tìm kiếm sẽ lâu hơn.

Trên là bài test cũng như những đánh giá của riêng cá nhân tôi nên có thể chưa phải đã tuyệt đối chính xác. Các thành viên có thể trao đổi làm rõ thêm tại topic này. Thêm nữa là các tác giả đã gửi bài bằng file hoặc code tại topic này có thể gửi lại code "LapSo" và các hàm, thủ tục của mình lên đây kèm theo những comment thật chi tiết và rõ ràng để các thành viên có điều kiện học tập.
Thông qua topic viết VBA tốc độ tối ưu này rõ ràng chúng ta được học lẫn nhau bởi các phương pháp đa dạng, tăng kiến thức VBA. Các thành viên GPE có nguồn thư viện để học tập, vận dụng cho bài toán thực tế. Các thành viên tham gia trao đổi và gửi bài phần lới đều có kinh nghiệm, kiến thức tốt về VBA, không ngại việc thắng thua, không dị ứng với từ "THI" mà theo đúng với tinh thần của topic này là giao lưu học hỏi lẫn nhau, các anh đúng là các người thầy thực sự của rất nhiều thành viên GPE về kiến thức, tinh thần học học và chia sẻ.

Dưới đây là toàn bộ mã nguồn của các tác giả gửi. Các thành viên nên download tất cả để tìm hiểu các phương pháp khác nhau. Các thành viên hãy bấm nút "Thanks" như một sự động viên và khuyến khích các tác giả tiếp tục đóng góp cho chúng ta nhé!

 

[dhn46]

Cảm ơn anh Nguyễn Duy Tuân đã tạo một topic hay để chúng em được học các phương án hay từ các thành viên GPE và dhn46 cũng cảm ơn các anh chị đã nhiệt tình tham gia cho em được mở mang thêm kiến thức.

Với những thành viên "mới tiếp cận VBA" em cũng đề xuất chú ý thêm phần đặt biến tạm, bởi nếu tận dụng nó thì tốc độ cũng tăng thêm một chút như bài #138 em đã nói đến.

Nhờ anh Nguyễn Duy Tuân Test hộ em Code sau khi dùng biến tạm để có thể so sánh với việc không dùng biến tạm tại bài #175.
Qua bài #139 của anh Vodoi2x em cũng đã test và thấy nếu dùng .Value2 gán cho mảng thì tốc độ cũng được cải thiện, đây là một cái mới với em mà quan topic này em đã may mắn được biết.

(Code sử dụng biến tạm - chưa áp dụng .Value2 để gán mảng)

Sub LapSo()
'Tat update man hinh, tu dong tinh toan
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    'Khai bao bien
    Dim ArrData, ArrDM, Res
    Dim iR  As Long
    Dim jC  As Long
    Dim k   As Long
    Dim p   As Long
    Dim Code As String
    Dim FDate As Date
    Dim TDate As Date
    Dim DicDM As Object
    Dim DicData As Object
    'Khoi tao Dictionary
    Set DicDM = CreateObject("Scripting.Dictionary")
    Set DicData = CreateObject("Scripting.Dictionary")


    'Gan gia tri vao mang
    ArrData = Sheets("KHO").[A4].Resize(Sheets("KHO").[A4].End(xlDown).Row - 3, 11)
    ArrDM = Sheets("DM VLSPHH").[A4].Resize(Sheets("DM VLSPHH").[A4].End(xlDown).Row - 3, 4)
    ReDim Res(1 To UBound(ArrDM, 1) + 1, 1 To 12)
    FDate = Sheets("SETTING").[B1].Value2    'Tu ngay
    TDate = Sheets("SETTING").[B2].Value2    'Den ngay
    'Dua du lieu vao DicDM (danh muc hang hoa)
    For iR = 1 To UBound(ArrDM, 1)
        If Not DicDM.Exists(ArrDM(iR, 1)) Then
            k = k + 1
            DicDM.Add ArrDM(iR, 1), k
        End If
    Next
    k = 0
    'Duyet 1 vong qua Data
    For iR = 1 To UBound(ArrData, 1)
        Code = ArrData(iR, 7)
        If ArrData(iR, 2) <= TDate Then
            If Not DicData.Exists(Code) Then
                k = k + 1
                DicData.Add Code, k
                Res(k, 1) = k
                Res(k, 2) = Code
                Res(k, 3) = ArrDM(DicDM.Item(Code), 2)
                Res(k, 4) = ArrDM(DicDM.Item(Code), 3)
                'Khoi tao gia tri
                If ArrData(iR, 2) < FDate Then        'Ton
                    Res(k, 5) = ArrData(iR, 8)
                    Res(k, 6) = ArrData(iR, 11)
                Else        'Trong ky
                    p = DicData.Item(Code)
                    If ArrData(iR, 10) = "N" Then        'Nhap
                        Res(p, 7) = ArrData(iR, 8)
                        Res(p, 8) = ArrData(iR, 11)
                    Else        'Xuat
                        Res(p, 9) = ArrData(iR, 8)
                        Res(p, 10) = ArrData(iR, 11)
                    End If
                End If
            Else        'Truy xuat cac gia tri da co
                p = DicData.Item(Code)
                If ArrData(iR, 2) < FDate Then        'Ton
                    Res(p, 5) = Res(p, 5) + ArrData(iR, 8)
                    Res(p, 6) = Res(p, 6) + ArrData(iR, 11)
                Else        'Trong ky
                    If ArrData(iR, 10) = "N" Then        'Nhap
                        Res(p, 7) = Res(p, 7) + ArrData(iR, 8)
                        Res(p, 8) = Res(p, 8) + ArrData(iR, 11)
                    Else        'Xuat
                        Res(p, 9) = Res(p, 9) + ArrData(iR, 8)
                        Res(p, 10) = Res(p, 10) + ArrData(iR, 11)
                    End If
                End If
            End If
        End If
    Next
    'Tinh ton cuoi va cac gia tri tong cong
    For jC = 5 To 10
        For iR = 1 To k
            If jC / 2 = Int(jC / 2) Then
                Res(k + 1, jC) = Res(k + 1, jC) + Res(iR, jC)
            End If
            Res(iR, 11) = Res(iR, 5) + Res(iR, 7) - Res(iR, 9)
            Res(iR, 12) = Res(iR, 6) + Res(iR, 8) - Res(iR, 10)
        Next
    Next
    Res(k + 1, 12) = Res(k + 1, 6) + Res(k + 1, 8) - Res(k + 1, 10)
    Res(k + 1, 3) = "C" & ChrW(7897) & "ng:"
    'Gan du lieu xuong Sheet
    Sheets("THNXT").Range("B12:B65535").EntireRow.Delete
    If k Then
        Sheets("THNXT").Range("B12").Resize(k + 1, 12) = Res
        Set DicDM = Nothing
        Set DicData = Nothing
        'Dinh dang
        With Sheets("THNXT")
            .Range("B10").CurrentRegion.NumberFormat = "#,##0"
            .Range("B10").CurrentRegion.Font.Size = 12
            .Range("B" & k + 12 & ":M" & k + 12).Font.Bold = True
            .Range("B" & 12 & ":M" & k + 11).Borders.LineStyle = xlContinuous
            .Range("B" & 12 & ":M" & k + 11).Borders(xlInsideHorizontal).LineStyle = xlDash
            .Range("B" & k + 12 & ":M" & k + 12).Borders.LineStyle = xlContinuous
        End With
    End If
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[ptm0412]

Xem sơ code của dhn thì thấy tồn đầu chỉ tính cộng nhập mà không trừ xuất. Như vậy, nếu trước ngày bắt đầu không phải 1/8 mà là 1/9, thì số dư đầu bao gồm cả nhập và xuất trước ngày FDate, nhưng toàn là cộng chứ không trừ. Dẫn đến tồn đầu sai.

Thứ hai, DicData lấy trong dữ liệu và phải kiểm tra sự tồn tại 65.000 lần. Nên biết rằng 1 lần kiểm tra sự tồn tại tức là 1 thao tác phải tính thời gian. Nhân lên 65000 lần sẽ ra 1 con số đáng kể. Code của tôi chỉ 1 Dic lấy từ danh mục, và khi duyệt Data. chỉ truy xuất chứ không kiểm tra nữa.

Sau đó, để loại trừ các mặt hàng không tồn cũng không nhập xuất, tôi phải kiểm tra, nhưng lần này chỉ kiểm tra bằng vòng lặp 12 vòng. Giả sử không phải 12, cũng chắc chắn là ít hơn 65.000 mặt hàng.

 

[ptm0412]

Tuy vậy, PTM xem bổ sung việc lỗi xảy ra khi - Mã hàng không tồn tại trong "bảng danh mục" (sheet DM VLSPHH) nhưng lại có trong KHO
Vì dụ giờ ta có mã hàng mới là HH099 xuất hiện trong kho --> khi đó chương trình có lỗi -

Đối với việc quản lý kho hàng thì thông thường người ta đã bắt lỗi ngay khi nhập xuất 1 mặt hàng không có trong danh mục. Do đó tôi viết code dựa vào cơ sở không có việc chưa có mặt hàng đã mua bán. Vả lại, nếu có trường hợp này xảy ra thì sẽ chỉ có mã mà không có tên và đơn vị tính tương ứng, vì cấu trúc Data không có.

Cái vụ màu đỏ em đã sử dụng từ rất lâu rồi ạ và thuật toán Mảng trong Mảng cũng thú vị và rất nhanh đấy Sư phụ ạ. Riêng cái Collection (có thể nó có ở đâu đó trên diễn đàn mà tôi chưa thấy) thì mới biết từ bài của Vodoi2x

Mảng trong mảng không phải là thuật toán mà chỉ là thủ thuật (phương tiện) để thực hiện thuật toán mà thôi. Ngoài ra, nó có thể thú vị, nhưng không nhanh. Mới cách đây mấy ngày Nghĩa nói chậm, hôm nay lại nói nhanh là sao?

Gởi Tuân,

Tuân test hộ code tôi đưa lên lần 2 ở bài #262 xem có phải trung bình 270 không.

Về Pivot table, tôi không đồng ý về việc tăng dung lượng. Nó chỉ lưu trữ dưới dạng số, không hề có công thức và cũng không tính toán lại thường xuyên. Tôi có xem bài của Duy Thương, refresh (tức là tính toán lại) cũng khoảng 400ms, cộng với code copy ăn gian 50 ms, cũng thuộc loại có hạng. Ăn gian như vậy không đúng, vì không phải cứ ngày bắt đầu đó, ngày kết thúc đó mà tính mãi. Phải thay đổi xem báo cáo tháng này, báo cáo tháng kia, báo cáo quý, báo cáo năm, chứ không chỉ xem mãi 1 báo cáo, hoặc có 1 báo cáo tính đi tính lại mãi. Do đó phải tính thêm thời gian refresh.

Chỉ có điều Thương làm chưa đến nơi đến chốn, vì chưa lường trước 1 số việc:
- Giả sử để tính đầu kỳ có cả cộng nhập và trừ xuất, thì đầu kỳ sai
- Giả sử trong kỳ chỉ có nhập không có xuất, hoặc có xuất không nhập, hoặc không có cả 2, thì code copy sẽ copy sai.

 

[Hoàng Trọng Nghĩa]

Tôi áp dụng 2 việc của vodoi2x vào code của tôi:
- Dùng Value2
- Dùng 5 mảng data nguồn 1 cột thay vì 1 mảng 11 cột
- Giữ nguyên thuật toán (sửa 2 biến Date đều thành Long, cho khỏi ngộ ngộ.)

Sau đó so với code của vodoi2x "Dictionary only" bài mới nhất #156, thấy code của tôi luôn nhanh hơn code vodoi2x của lần chạy đầu tiên.
phương pháp test:
Code:

Sub LapSo()
    Application.ScreenUpdating = False
    Dim ListArr(), sArrID(), TmpArr(), RArr(), sArrQty(), sArrAmt(), sArrDocType(), sArrDate()
    Dim Dic1 As Object, EndR As Long, ListCt As Long
    Dim DataCt As Long, ListEndR As Long, Date1 As Long, Date2 As Long
    Dim i As Long, j As Long, k As Long, Check As Double
    ListEndR = Sheet1.[A100].End(xlUp).Row
    Set Dic1 = CreateObject("Scripting.Dictionary")
    ''Lay danh muc vao mang
    ListArr = Sheet1.Range("A4:C" & ListEndR).Value2
    ListCt = UBound(ListArr, 1)
    ''Nap mang danh muc vao Dic
    For i = 1 To ListCt
        Dic1.Add ListArr(i, 1), i
    Next
    ''Xác dinh dong cuoi cua data va nap vao mang
    With Sheet20
    EndR = .Cells(4, 1).End(xlDown).Row
        sArrID = .Range("G4:G" & EndR).Value2
        sArrQty = .Range("H4:H" & EndR).Value2
        sArrAmt = .Range("K4:K" & EndR).Value2
        sArrDocType = .Range("J4:J" & EndR).Value2
        sArrDate = .Range("B4:B" & EndR).Value2
    End With
    DataCt = EndR - 3
    '' gan gia tri cho bien
    ReDim TmpArr(1 To ListCt, 1 To 7)
    Date1 = Sheet3.[B1]
    Date2 = Sheet3.[B2]
    ''Duyet mang Data
    For i = 1 To DataCt
            ' 'Xac dinh dong chua ma HH trong danh muc, gan vao cot 1 cua KQ tam
            j = Dic1.Item(sArrID(i, 1))
            TmpArr(j, 1) = j
        ''Neu ngay < ngay bat dau, tinh 2 cot ton dau
        If sArrDate(i, 1) < Date1 Then
            If sArrDocType(i, 1) = "N" Then
                ''Cong nhap
                TmpArr(j, 2) = TmpArr(j, 2) + sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) + sArrAmt(i, 1)
            Else
                ''Tru xuat
                TmpArr(j, 2) = TmpArr(j, 2) - sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) - sArrAmt(i, 1)
            End If
        ''Neu ngay trong khoang bao cao
        ElseIf sArrDate(i, 1) <= Date2 Then
            ''Neu loai chung tu là N, tinh 2 cot Nhap
            If sArrDocType(i, 1) = "N" Then
                TmpArr(j, 4) = TmpArr(j, 4) + sArrQty(i, 1)
                TmpArr(j, 5) = TmpArr(j, 5) + sArrAmt(i, 1)
            ''Neu loai chung tu la X, tinh 2 cot xuat
            Else
                TmpArr(j, 6) = TmpArr(j, 6) + sArrQty(i, 1)
                TmpArr(j, 7) = TmpArr(j, 7) + sArrAmt(i, 1)
            End If
        End If
    ''Ket thuc vong lap, Mang KQ tam co 12 dong
    Next
    ''Khai bao  Mang KQua
    ReDim RArr(1 To ListCt, 1 To 12)
    k = 0
    ''Duyet mang KQ tam
    For i = 1 To ListCt
            ''Kiem tra dong co du lieu
            Check = TmpArr(i, 2) + TmpArr(i, 3) + TmpArr(i, 4) + _
            TmpArr(i, 5) + TmpArr(i, 6) + TmpArr(i, 7)
        ''Neu co dulieu, them vao mang KQua
        If Check > 0 Then
            k = k + 1
            ''4 cot thong so Hang hoa
            RArr(k, 1) = k
            RArr(k, 2) = ListArr(i, 1)
            RArr(k, 3) = ListArr(i, 2)
            RArr(k, 4) = ListArr(i, 3)
            ''6 cot Ton, nhap, xuat
            For j = 5 To 10
               RArr(k, j) = TmpArr(i, j - 3)
            Next
            ''2 cot Ton cuoi
            RArr(k, 11) = RArr(k, 5) + RArr(k, 7) - RArr(k, 9)
            RArr(k, 12) = RArr(k, 6) + RArr(k, 8) - RArr(k, 10)
           
        End If
    Next
    '' Gan ket qua xuong sau khi xoa
    Sheet26.[B12].Resize(12, 12).ClearContents
    Sheet26.[B12].Resize(k, 12) = RArr
Set Dic1 = Nothing
Application.ScreenUpdating = True
End Sub

Khi thực hiện trên CSDL, nếu không kiểm tra trước sẽ luôn luôn phát sinh lỗi về dữ liệu.

(1) Dữ liệu không có ở sheet KHO --> LỖI (nếu không bẫy lỗi này thì luôn luôn xảy ra lỗi nếu dùng mảng)

(2) Dữ liệu chỉ 1 hàng duy nhất --> LỖI

Với mục (2) tại sao lỗi? Bởi vì khi thực hiện với mảng 1 cột, thì dữ liệu chỉ có 1 cell thì chưa tạo thành mảng nên phát sinh ra lỗi. Vì vậy, những ai mới sử dụng kiểu này thì phải bẫy lỗi này bằng cách:

a) Xét 1 mảng xem có phải là mảng chưa, nếu không phải là mảng thì hoặc xử lý trực tiếp (nhu bài nộp anh Tuân) hoặc chuyển phần tử không phải là mảng về thành mảng (cách này tôi nghĩ tốt hơn mà tôi mới nghiệm ra):

[GPECODE=vb]
With Sheets("KHO").Range("B4:B" & LastRow)
ArrData(1) = .Offset(, 5).Value2 'MA_VLSPHH
ArrData(2) = .Offset(, 6).Value2 'SLG
ArrData(3) = .Offset(, 9).Value2 'THANH_TIEN
ArrData(4) = .Offset(, 8).Value2 'LOAI_PHIEU
ArrData(5) = .Value2 'NGAY_CT
End With

If Not IsArray(ArrData(1)) Then
Dim ArrTemp(1 To 1, 1 To 1)
For c = 1 To 5
ArrTemp(1, 1) = ArrData(c)
ArrData(c) = ArrTemp
Next
End If
[/GPECODE]

b) Không cần xét mà phải thêm 1 hàng vào nữa, nhưng chú ý tới vấn đề "cạn dòng" (tức sheet có bao nhiêu hàng và dữ liệu cũng đã có nhiêu đó hàng - hiếm nhưng cũng có khả năng phát sinh). Vì thế khi bẫy lỗi trong vòng lặp phải loại trừ dòng rỗng (cách này coi bộ không ổn vì phải loại trừ nhiều lần trong vòng lặp). Như trường hơp của Vodoi2x vì đã thêm 1 dòng rỗng, nhưng do không bẫy lỗi khi gán vào biểu mẫu thay vì chỉ 1 mã hàng được chọn thì sẽ có 2 mã hàng, trong đó có 1 mã là rỗng.

 

[Nguyễn Duy Tuân]

Bài của anh ptm0412 có cải tiến theo kinh nghiệm của vodoi2x tốc độ đạt 317 mili giây. Kết quả vậy là rất nhanh. Cách viết code của anh anh ptm0412 khá giống với em.

Tôi áp dụng 2 việc của vodoi2x vào code của tôi:
- Dùng Value2
- Dùng 5 mảng data nguồn 1 cột thay vì 1 mảng 11 cột
- Giữ nguyên thuật toán (sửa 2 biến Date đều thành Long, cho khỏi ngộ ngộ.)

Sau đó so với code của vodoi2x "Dictionary only" bài mới nhất #156, thấy code của tôi luôn nhanh hơn code vodoi2x của lần chạy đầu tiên.
phương pháp test:
- Code vodoi2x: Xóa những gì liên quan đến 2 biến Run1K và Run1D, xem như không dùng đến dữ liệu đang lưu trữ, mỗi lần chạy là mỗi lần nạp, và chạy 10 lần lấy trung bình.
- Code của tôi cũng chạy 10 lần lấy trung bình
- Đóng excel, test lại 10 lần nữa.



Code:

Sub LapSo()
    Application.ScreenUpdating = False
    Dim ListArr(), sArrID(), TmpArr(), RArr(), sArrQty(), sArrAmt(), sArrDocType(), sArrDate()
    Dim Dic1 As Object, EndR As Long, ListCt As Long
    Dim DataCt As Long, ListEndR As Long, Date1 As Long, Date2 As Long
    Dim i As Long, j As Long, k As Long, Check As Double
    ListEndR = Sheet1.[A100].End(xlUp).Row
    Set Dic1 = CreateObject("Scripting.Dictionary")
    ''Lay danh muc vao mang
    ListArr = Sheet1.Range("A4:C" & ListEndR).Value2
    ListCt = UBound(ListArr, 1)
    ''Nap mang danh muc vao Dic
    For i = 1 To ListCt
        Dic1.Add ListArr(i, 1), i
    Next
    ''Xác dinh dong cuoi cua data va nap vao mang
    With Sheet20
    EndR = .Cells(4, 1).End(xlDown).Row
        sArrID = .Range("G4:G" & EndR).Value2
        sArrQty = .Range("H4:H" & EndR).Value2
        sArrAmt = .Range("K4:K" & EndR).Value2
        sArrDocType = .Range("J4:J" & EndR).Value2
        sArrDate = .Range("B4:B" & EndR).Value2
    End With
    DataCt = EndR - 3
    '' gan gia tri cho bien
    ReDim TmpArr(1 To ListCt, 1 To 7)
    Date1 = Sheet3.[B1]
    Date2 = Sheet3.[B2]
    ''Duyet mang Data
    For i = 1 To DataCt
            ' 'Xac dinh dong chua ma HH trong danh muc, gan vao cot 1 cua KQ tam
            j = Dic1.Item(sArrID(i, 1))
            TmpArr(j, 1) = j
        ''Neu ngay < ngay bat dau, tinh 2 cot ton dau
        If sArrDate(i, 1) < Date1 Then
            If sArrDocType(i, 1) = "N" Then
                ''Cong nhap
                TmpArr(j, 2) = TmpArr(j, 2) + sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) + sArrAmt(i, 1)
            Else
                ''Tru xuat
                TmpArr(j, 2) = TmpArr(j, 2) - sArrQty(i, 1)
                TmpArr(j, 3) = TmpArr(j, 3) - sArrAmt(i, 1)
            End If
        ''Neu ngay trong khoang bao cao
        ElseIf sArrDate(i, 1) <= Date2 Then
            ''Neu loai chung tu là N, tinh 2 cot Nhap
            If sArrDocType(i, 1) = "N" Then
                TmpArr(j, 4) = TmpArr(j, 4) + sArrQty(i, 1)
                TmpArr(j, 5) = TmpArr(j, 5) + sArrAmt(i, 1)
            ''Neu loai chung tu la X, tinh 2 cot xuat
            Else
                TmpArr(j, 6) = TmpArr(j, 6) + sArrQty(i, 1)
                TmpArr(j, 7) = TmpArr(j, 7) + sArrAmt(i, 1)
            End If
        End If
    ''Ket thuc vong lap, Mang KQ tam co 12 dong
    Next
    ''Khai bao  Mang KQua
    ReDim RArr(1 To ListCt, 1 To 12)
    k = 0
    ''Duyet mang KQ tam
    For i = 1 To ListCt
            ''Kiem tra dong co du lieu
            Check = TmpArr(i, 2) + TmpArr(i, 3) + TmpArr(i, 4) + _
            TmpArr(i, 5) + TmpArr(i, 6) + TmpArr(i, 7)
        ''Neu co dulieu, them vao mang KQua
        If Check > 0 Then
            k = k + 1
            ''4 cot thong so Hang hoa
            RArr(k, 1) = k
            RArr(k, 2) = ListArr(i, 1)
            RArr(k, 3) = ListArr(i, 2)
            RArr(k, 4) = ListArr(i, 3)
            ''6 cot Ton, nhap, xuat
            For j = 5 To 10
               RArr(k, j) = TmpArr(i, j - 3)
            Next
            ''2 cot Ton cuoi
            RArr(k, 11) = RArr(k, 5) + RArr(k, 7) - RArr(k, 9)
            RArr(k, 12) = RArr(k, 6) + RArr(k, 8) - RArr(k, 10)
           
        End If
    Next
    '' Gan ket qua xuong sau khi xoa
    Sheet26.[B12].Resize(12, 12).ClearContents
    Sheet26.[B12].Resize(k, 12) = RArr
Set Dic1 = Nothing
Application.ScreenUpdating = True
End Sub