Nhờ viết code mảng và dictionary cho bảng excel 300.000 dòng

[hoaphin]

Hôm trước em có nhờ bác Hữu Thắng nhưng bác ý đang bận, nên em mạn phép viết nên đây để nhờ các bác giúp em với ạ (bác Hữu Thắng mà có thời gian rồi thì cũng giúp em với nhé)
File em nguyên tắc : từ dòng trả sẽ trừ ngược lên để ra được số lượng xuất mới, dòng dưới được hiểu là ngày xuất sau sẽ không ảnh hưởng bởi dòng trả ở trên
Điều kiện: cùng mã khách, cùng mã hàng
Do file có khoảng 300.000 dòng nên em dùng vòng lặp thì rất chậm, hôm trước bác Hữu Thắng dùng dictionary với mảng thì rất nhanh (nhưng nay sếp em yêu cầu thay đổi cách tính khác nên phải chỉnh lại ạ), file em đã lược bớt để vài dòng làm mẫu cho nhẹ
Em cảm ơn ạ

 

[HieuCD]

Hôm trước em có nhờ bác Hữu Thắng nhưng bác ý đang bận, nên em mạn phép viết nên đây để nhờ các bác giúp em với ạ (bác Hữu Thắng mà có thời gian rồi thì cũng giúp em với nhé)
File em nguyên tắc : từ dòng trả sẽ trừ ngược lên để ra được số lượng xuất mới, dòng dưới được hiểu là ngày xuất sau sẽ không ảnh hưởng bởi dòng trả ở trên
Điều kiện: cùng mã khách, cùng mã hàng
Do file có khoảng 300.000 dòng nên em dùng vòng lặp thì rất chậm, hôm trước bác Hữu Thắng dùng dictionary với mảng thì rất nhanh (nhưng nay sếp em yêu cầu thay đổi cách tính khác nên phải chỉnh lại ạ), file em đã lược bớt để vài dòng làm mẫu cho nhẹ
Em cảm ơn ạ
View attachment 290154

Kiểm tra lại . .

Sub XYZ()
  Dim aKH(), aVT(), asl(), a, res(), dic As Object, key$
  Dim sRow&, i&, j&, sl#

  i = Sheet1.Range("G" & Rows.Count).End(xlUp).Row
  If i < 2 Then
    MsgBox "Khong co data de tinh toan!"
    Exit Sub
  End If
  aKH = Sheet1.Range("D2:D" & i).Value
  aVT = Sheet1.Range("G2:G" & i).Value
  res = Sheet1.Range("K2:K" & i).Value
  asl = Sheet1.Range("L2:L" & i).Value
  sRow = UBound(aKH)
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To sRow
    key = aKH(i, 1) & "|" & aVT(i, 1)
    If res(i, 1) > 0 Then
      If dic.exists(key) = False Then
        dic.Add key, Array(i)
      Else
        a = dic(key)
        ReDim Preserve a(0 To UBound(a) + 1)
        a(UBound(a)) = i
        dic(key) = a
      End If
    ElseIf asl(i, 1) > 0 Then
      If dic.exists(key) Then
        sl = asl(i, 1)
        a = dic(key)
        For j = UBound(a) To 0 Step -1
          If res(a(j), 1) <= sl Then
            sl = sl - res(a(j), 1)
            res(a(j), 1) = 0
          Else
            res(a(j), 1) = res(a(j), 1) - sl
            sl = 0
          End If
          If sl = 0 Then Exit For
        Next j
      End If
    End If
  Next i
  Sheet1.Range("M2").Resize(sRow).Value = res
End Sub

 

[hoaphin]

Kiểm tra lại . .

Sub XYZ()
  Dim aKH(), aVT(), asl(), a, res(), dic As Object, key$
  Dim sRow&, i&, j&, sl#

  i = Sheet1.Range("G" & Rows.Count).End(xlUp).Row
  If i < 2 Then
    MsgBox "Khong co data de tinh toan!"
    Exit Sub
  End If
  aKH = Sheet1.Range("D2:D" & i).Value
  aVT = Sheet1.Range("G2:G" & i).Value
  res = Sheet1.Range("K2:K" & i).Value
  asl = Sheet1.Range("L2:L" & i).Value
  sRow = UBound(aKH)
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To sRow
    key = aKH(i, 1) & "|" & aVT(i, 1)
    If res(i, 1) > 0 Then
      If dic.exists(key) = False Then
        dic.Add key, Array(i)
      Else
        a = dic(key)
        ReDim Preserve a(0 To UBound(a) + 1)
        a(UBound(a)) = i
        dic(key) = a
      End If
    ElseIf asl(i, 1) > 0 Then
      If dic.exists(key) Then
        sl = asl(i, 1)
        a = dic(key)
        For j = UBound(a) To 0 Step -1
          If res(a(j), 1) <= sl Then
            sl = sl - res(a(j), 1)
            res(a(j), 1) = 0
          Else
            res(a(j), 1) = res(a(j), 1) - sl
            sl = 0
          End If
          If sl = 0 Then Exit For
        Next j
      End If
    End If
  Next i
  Sheet1.Range("M2").Resize(sRow).Value = res
End Sub

em cảm ơn bác nhé, em thấy kết quả ra chuẩn chỉ rồi ạ