Chuyển từ Công thức mảng: Index/match/countifs sang code VBA để tối ưu tốc độ xử lý file

[pham ha 94]

Nhờ các bác giúp đỡ mình Chuyển từ Công thức mảng: Index/match/countifs sang code VBA để tối ưu tốc độ xử lý file.

Mình có file (đính kèm)
- Hiện cột I và J dùng công thức mảng: Các tham chiếu: ngày tháng, số tài khoản, số tiền trùng nhau thì liệt kê lần lượt các Page tiếp theo
- Tuy ra kết quả đúng nhưng chạy dữ liệu khoảng 10 dòng mà mất 1p.
Bảng dữ liệu gốc từ 5000-6000 dòng nên chạy rất lâu hoặc treo luôn excel.

Mong muốn: Tại Sheets(Data Voso) cột (I và J) có thể chạy VBA để xử lý nhanh hơn.
Xin cảm ơn các bác nhiều.

 

[HieuCD]

Nhờ các bác giúp đỡ mình Chuyển từ Công thức mảng: Index/match/countifs sang code VBA để tối ưu tốc độ xử lý file.

Mình có file (đính kèm)
- Hiện cột I và J dùng công thức mảng: Các tham chiếu: ngày tháng, số tài khoản, số tiền trùng nhau thì liệt kê lần lượt các Page tiếp theo
- Tuy ra kết quả đúng nhưng chạy dữ liệu khoảng 10 dòng mà mất 1p.
Bảng dữ liệu gốc từ 5000-6000 dòng nên chạy rất lâu hoặc treo luôn excel.

Mong muốn: Tại Sheets(Data Voso) cột (I và J) có thể chạy VBA để xử lý nhanh hơn.
Xin cảm ơn các bác nhiều.

Kiểm tra lại . .

Sub XYZ()
  Dim aNC(), aNo(), aCo(), res(), dic As Object, key$
  Dim sRow&, i&, tmp$
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data Ghino")
    aNo = .Range("A2", .Range("E" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aNo)
  For i = 1 To sRow
    key = "No" & aNo(i, 3) & "|" & aNo(i, 4) & "|" & aNo(i, 5)
    dic(key) = dic(key) & aNo(i, 1) & ","
  Next i
 
  With Sheets("Data Ghico")
    aCo = .Range("A2", .Range("E" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aCo)
  For i = 1 To sRow
    key = "Co" & aCo(i, 3) & "|" & aCo(i, 4) & "|" & aCo(i, 5)
    dic(key) = dic(key) & aCo(i, 1) & ","
  Next i
 
  With Sheets("Data Voso")
    aNC = .Range("C2:H" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(aNC)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    If aNC(i, 5) <> Empty Then
      Call AddRes(res, i, dic, "No" & aNC(i, 1) & "|" & aNC(i, 5) & "|" & aNC(i, 2), 1)
    Else
      Call AddRes(res, i, dic, "Co" & aNC(i, 1) & "|" & aNC(i, 6) & "|" & aNC(i, 2), 2)
    End If
  Next i
  Sheets("Data Voso").Range("I2").Resize(sRow, 2) = res
End Sub

Private Sub AddRes(res, i, dic, ByVal key$, ByVal j&)
  Dim c&, tmp$
  If dic.Exists(key) Then
    tmp = dic(key)
    c = InStr(1, tmp, ",")
    res(i, j) = Mid(tmp, 1, c - 1)
    If c = Len(tmp) Then
      dic.Remove (key)
    Else
      dic(key) = Mid(tmp, c + 1)
    End If
  End If
End Sub

 

[pham ha 94]

Kiểm tra lại . .

Sub XYZ()
  Dim aNC(), aNo(), aCo(), res(), dic As Object, key$
  Dim sRow&, i&, tmp$
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Data Ghino")
    aNo = .Range("A2", .Range("E" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aNo)
  For i = 1 To sRow
    key = "No" & aNo(i, 3) & "|" & aNo(i, 4) & "|" & aNo(i, 5)
    dic(key) = dic(key) & aNo(i, 1) & ","
  Next i
 
  With Sheets("Data Ghico")
    aCo = .Range("A2", .Range("E" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aCo)
  For i = 1 To sRow
    key = "Co" & aCo(i, 3) & "|" & aCo(i, 4) & "|" & aCo(i, 5)
    dic(key) = dic(key) & aCo(i, 1) & ","
  Next i
 
  With Sheets("Data Voso")
    aNC = .Range("C2:H" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(aNC)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    If aNC(i, 5) <> Empty Then
      Call AddRes(res, i, dic, "No" & aNC(i, 1) & "|" & aNC(i, 5) & "|" & aNC(i, 2), 1)
    Else
      Call AddRes(res, i, dic, "Co" & aNC(i, 1) & "|" & aNC(i, 6) & "|" & aNC(i, 2), 2)
    End If
  Next i
  Sheets("Data Voso").Range("I2").Resize(sRow, 2) = res
End Sub

Private Sub AddRes(res, i, dic, ByVal key$, ByVal j&)
  Dim c&, tmp$
  If dic.Exists(key) Then
    tmp = dic(key)
    c = InStr(1, tmp, ",")
    res(i, j) = Mid(tmp, 1, c - 1)
    If c = Len(tmp) Then
      dic.Remove (key)
    Else
      dic(key) = Mid(tmp, c + 1)
    End If
  End If
End Sub

Quá tuyệt vời, chạy êm ru luôn. Đọc mãi vẫn chưa học được sự tinh túy từ code của bác để sau này còn ứng dụng thêm vào các trường hợp khác.
Cảm ơn bác rất nhiều