Lấy DM duy nhất theo 2 cột = Scripting.Dictionary!

Chia sẻ bởi:hands

★★★★★

‹ Cần công thức tính một dạng Tổ... Giúp đỡ sửa VBA lấy dữ liệu... ›

Quảng cáo

Tôi mới học từ NDU và mày mò viết thử 1 code lấy DM duy nhất theo 2 cột = Scripting.Dictionary nhưng mà không chạy được, NDU hướng dẫn giúp nhé.

Sub UniqueArray2()
Dim endR As Long 'Copy NDU
Dim Src As Variant, Arr As Variant
Dim Dic1, Dic2, Tmp
Dim Items, Keys, i As Long, j As Long, TG As Double

TG = Timer
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
endR = .Cells(65000, 1).End(xlUp).Row
ReDim Arr(1 To endR, 1 To 2)
With Range("A2:B" & endR)
Src = .Value
End With
For i = 1 To UBound(Src)
Tmp = CStr(Src(i, 1) & Src(i, 2))
Dic1.Add i, Tmp
If Not Dic1.Exists(Tmp) Then
j = j + 1
Items = Src(i, 1)
Keys = Src(i, 2)
Dic2.Add Items, Keys
Arr(j, 1) = Items
Arr(j, 1) = Keys
End If
Next
End With
If j = 0 Then Exit Sub
Range("H2:I" & j + 1).Value = Arr

MsgBox Format(Timer – TG, "0.000000000")
End Sub

Cám ơn nhiều.

Thử vầy xem:

Sub UniqueArray2()
Dim Src, Tmp, Arr(1 To 65535, 1 To 2)
Dim i As Long, j As Long, TG As Double
TG = Timer
With Sheets("Data")
Src = .Range(., ..End(xlUp)).Resize(, 2).Value
End With
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Src)
If Src(i, 1) <> "" Or Src(i, 2) <> "" Then
Tmp = Src(i, 1) & Src(i, 2)
If Not .Exists(Tmp) Then
j = j + 1
.Add Tmp, ""
Arr(j, 1) = Src(i, 1)
Arr(j, 2) = Src(i, 2)
End If
End If
Next
End With
If j <> 0 Then
Range("H2").Resize(j, 2).Value = Arr
MsgBox Format(Timer – TG, "0.000000000")
End If
End Sub
Đâu cần ReDim mảng chi cho mất công chứ ThuNghi —> Lọc ra đến bao nhiêu ta lấy bấy nhiêu thôi, chẳng ảnh hưởng gì đến tốc độ cả

Redim là do thói quen thôi. Cám ơn NDU nhiều.
Không hiểu phần này code trên sai chỗ nào. Về logich thấy có vẻ đúng.
If Not Dic1.Exists(Tmp) Then
j = j + 1
Items = Src(i, 1)
Keys = Src(i, 2)
Dic2.Add Items, Keys
Arr(j, 1) = Items
Arr(j, 1) = Keys
End If

đoạn này:

If Not Dic1.Exists(Tmp) Then
j = j + 1
Items = Src(i, 1)
Keys = Src(i, 2)
Dic2.Add Items, Keys
Arr(j, 1) = Items
Arr(j, 1) = Keys không hiểu
Kiểm tra sự tồn tại của Tmp nhưng lại đi Add Src(i, 1) vào Keys —> Chẳng ăn nhậu gì với Tmp cả
Giống vầy:
– Cầm tấm thẻ học sinh, tra vào danh sách lớp, nếu chưa tồn tại thì.. ghi thêm tên của thẻ ấy vào danh sách
Đàng này ThuNghi lại:
– Cầm tấm thẻ học sinh, tra vào danh sách lớp, nếu chưa tồn tại thì.. ghi thêm tên của 1 cha lạ hoắc nào đó vào —> Liên quan gỉ đến tấm thẻ đang cầm trong tay?

Kiểm tra tmp có tồn tại tại Dic1 chưa, nếu không mình add vào Dic2 mà. 2 Dic này khai báo độc lập với nhau.

Uh… hiểu rồi… nhưng cũng.. sai luôn! Vì trong nhóm Keys của Dic1 làm gì có Tmp
Đoạn trên của ThuNghi là Dic1.Add i, Tmp cơ mà —> Tức i nằm trong nhóm Keys và Tmp nằm trong nhóm Items
Hic..
Khi kiểm tra sự tồn tại của 1 phần tử trong Dictionary Object, nó sẽ dò phần tử ấy trong Keys mà thôi, chẳng để ý gì Items đâu
Câu lệnh:
Dic.Exists(gì gì đó)
Gần như tương đương với
MATCH(gì gì đó, Dic.Keys,0)
Nếu MATCH không báo lỗi và có kết quả thì xem như CÓ TỒN TẠI
———————
Thuật toán cho bài này là:
– Quét từ trên xuống
– Nối 2 cột lại thành 1 biến tạm, là Tmp
– Kiểm tra sự tồn tại của Tmp trong Dictionary Object, nếu chưa có thì Add Tmp vào… Đồng thời gán giá trị 2 cột vào mảng luôn
Vậy:
– Dictionary Object trong code này chỉ làm nhiệm vị kiểm tra sự tồn tại, không làm nhiệm vụ lấy dữ liệu
– Chỉ cần 1 biến Dic là đủ

Vậy thì phải sửa code trên theo hướng add và 1 Dic khác nữa thì làm thế nào.
Có khi mình chưa cần gán vào Array, mình để thao tác tiếp, chỉ cần gán vào Dic đã.
Arr(j, 1) = Src(i, 1)
Arr(j, 2) = Src(i, 2)
Cám ơn nhiều. Mình đang tính triển khai lọc duy nhất theo nhiều cột (>2) và sum nhiều cột, ie khoản 4 Dic.

Chưa hiểu lắm chổ này

Vậy thì phải sửa code trên theo hướng add và 1 Dic khác nữa thì làm thế nào.
Có khi mình chưa cần gán vào Array, mình để thao tác tiếp, chỉ cần gán vào Dic đã.

————————————————-

Mình đang tính triển khai lọc duy nhất theo nhiều cột (>2) và sum nhiều cột, ie khoản 4 Dic.

Gữi bạn hàm tổng quát, lọc mấy cột tùy ý:

Function UniqueArray(SrcRng As Range)
Dim Src, Tmp As String, Arr()
Dim i As Long, j As Long, n As Long
Src = SrcRng.Value
ReDim Arr(1 To UBound(Src, 1), 1 To UBound(Src, 2))
With CreateObject("Scripting.Dictionary")
For i = LBound(Src, 1) To UBound(Src, 1)
Tmp = ""
For j = LBound(Src, 2) To UBound(Src, 2)
Tmp = Tmp & Src(i, j)
Next
If Tmp <> "" Then
If Not .Exists(Tmp) Then
n = n + 1
.Add Tmp, ""
For j = LBound(Src, 2) To UBound(Src, 2)
Arr(n, j) = Src(i, j)
Next
End If
End If
Next
End With
If j <> 0 Then
UniqueArray = Arr
End If
End Function
Sub chạy thí nghiệm với dữ liệu trên:

Sub Test()
Dim Arr, TG As Double
TG = Timer
With Sheets("Data")
Arr = UniqueArray(.Range(., ..End(xlUp)).Resize(, 2))
.Range("H2").Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
End With
MsgBox Timer – TG
End Sub

www.giaiphapexcel.com/diendan/threads/l%E1%BA%A5y-dm-duy-nh%E1%BA%A5t-theo-2-c%E1%BB%99t-scripting-dictionary.37895/post-251703

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 2 ▥ 0

‹ Cần công thức tính một dạng Tổ hợp Giúp đỡ sửa VBA lấy dữ liệu từ... ›

Quảng cáo

Bạn nên đọc

2 Responses

hands says:

31/12/2022 at 11:04 pm
Mình thấy chỉ cần mượn dic. làm bộ lọc còn ta chép luôn khỏi cần tạo mảng trung gian. Mình xin phép sửa vào Code của Ndu
```
Option Explicit
Sub UniqueArray()
  Dim Src, Tmp As String
  Dim i As Long, j As Long
  Dim SrcRng As Range, dich As Range
  Set SrcRng = Application.InputBox("Chon vung dinh loc (Co chua cot Tieu chuan)", , , , , , , 8)
  j = InputBox("Nhap so thu tu cot T/C trong vung chon")
  Set dich = Application.InputBox("Chon o dau vung chua ket qua", , , , , , , 8)
  Src = SrcRng.Value
  With CreateObject("Scripting.Dictionary")
    For i = LBound(Src, 1) To UBound(Src, 1)
        Tmp = Src(i, j)
      If Tmp <> "" Then
        If Not .Exists(Tmp) Then
          .Add Tmp, ""
          SrcRng.Rows(i).Copy dich
          Set dich = dich.Offset(1)
        End If
      End If
    Next
  End With
End Sub
```
Mình đọc không kỹ, còn vấn đề sum.
Ứng dụng trích lọc DS duy nhất từ 2 trong 3 cột thành bảng 2 chiều

Giả sử ta có bảng 1 như sau:

|

A

|

B

|

C

|

1

|

Company Name

|

services

|

price

|

2

|Company 01|Service 1|

1,01

|

3

|Company 01|Service 2|

1,02

|

4

|Company 01|Service 3|

1,03

|

5

|Company 02|Service 2|

1,04

|

6

|Company 02|Service 3|

1,05

|

7

|Company 03|Service 1|

1,06

|

8

|Company 04|Service 1|

1,07

|

9

|Company 04|Service 3|

1,08

|

Và muốn trích lọc thành bảng sau:

|

F

|

G

|

H

|

I

|

1

|

Company Name

|

Service 1

|

Service 2

|

Service 3

|

2

|Company 01|

1,01

|

1,02

|

1,03

|

3

|Company 02|

0

|

1,04

|

1,05

|

4

|Company 03|

1,06

|

0

|

0

|

5

|Company 04|

1,07

|

0

|

1,08

|

Code:

Sub Convert()
Dim vValue As Variant, vVals As Variant
Dim i As Long, EndR As Long, j As Long
Dim PriceRng As Range
Dim dArr1(), dArr2(), d1, d2, dPrice()
Dim MyDic1 As Object, MyDic2 As Object
EndR = .End(xlUp).Row
dArr1 = Sheet1.Range("A1:A" & EndR).Value
dArr2 = Sheet1.Range("b2:b" & EndR).Value

Set MyDic1 = CreateObject("scripting.dictionary")
Set MyDic2 = CreateObject("scripting.dictionary")

For Each d1 In dArr1
If d1 <> "" And Not MyDic1.exists(d1) Then
MyDic1.Add d1, ""
End If
Next d1
For Each d2 In dArr2
If d2 <> "" And Not MyDic2.exists(d2) Then
MyDic2.Add d2, ""
End If
Next d2

Sheet1..Resize(MyDic1.Count, 1).Value = Application.Transpose(MyDic1.keys)
Sheet1..Resize(1, MyDic2.Count).Value = MyDic2.keys

Set PriceRng = Sheet1..Offset(1, 1).Resize(MyDic1.Count – 1, MyDic2.Count)
ReDim dPrice(MyDic1.Count – 1, MyDic2.Count)
For i = 1 To MyDic1.Count – 1
For j = 1 To MyDic2.Count
dPrice(i, j) = Evaluate("=SumProduct((" & Range("A2:A" & EndR).Address & "=" & Sheet1.Cells(i + 1, 6).Address & ")*" _
& "(" & Range("b2:b" & EndR).Address & "=" & Sheet1.Cells(1, j + 6).Address & ")*(" _
& Range("c2:c" & EndR).Address & "))")
Next j, i
PriceRng.Value = dPrice
Set MyDic1 = Nothing
Set MyDic2 = Nothing
Set PriceRng = Nothing
Erase dArr1, dArr2, dPrice

End Sub

Ghi nhận sau khi thực hiện:
– Không cần mảng tạm cho Dictionary
– Có thể gán xuống sheet bằng Dictionary.Keys
– Mảng dArr1 và dArr2 chỉ dùng để lấy giá trị từ range sau đó gán vào Dictionary, thay vì lấy giá trị từ từng cell trên sheet.
– Mảng dPrice dùng để nhận giá trị sau đó gán xuống sheet 1 lần thay vì gán từng cell

Tốc độ rất nhanh.

http://www.giaiphapexcel.com/diendan/threads/l%E1%BA%A5y-dm-duy-nh%E1%BA%A5t-theo-2-c%E1%BB%99t-scripting-dictionary.37895/post-254743

Không cần nhiều vòng lập thế đâu sư phụ à! Em dùng 1 vòng lập là đủ

Sub Transfer(Src1 As Range, Src2 As Range, Src3 As Range, Target As Range)
Dim Arr(1 To 60000, 1 To 200), ScrArr1, SrcArr2, SrcArr3, Dic1, Dic2, Tmp1, Tmp2
Dim i As Long, iR As Long, iC As Long, n As Long, m As Long
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
ScrArr1 = Src1.Value
SrcArr2 = Src2.Value
SrcArr3 = Src3.Value
iR = 1: iC = 1
For i = 1 To UBound(ScrArr1)
If ScrArr1(i, 1) <> "" And SrcArr2(i, 1) <> "" Then
Tmp1 = ScrArr1(i, 1): Tmp2 = SrcArr2(i, 1)
If Not Dic1.Exists(Tmp1) Then
iR = iR + 1
Dic1.Add Tmp1, iR
Arr(iR, 1) = Tmp1
End If
n = WorksheetFunction.Match(Tmp1, Dic1.Keys, 0) + 1
If Not Dic2.Exists(Tmp2) Then
iC = iC + 1
Dic2.Add Tmp2, iC
Arr(1, iC) = Tmp2
End If
m = WorksheetFunction.Match(Tmp2, Dic2.Keys, 0) + 1
Arr(n, m) = Arr(n, m) + SrcArr3(i, 1)
End If
Next i
Target.Resize(iR, iC).Value = Arr
End Sub
Sub Main()
Dim Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, TG As Double
TG = Timer
With Range(, .End(xlUp))
Set Src1 = .Offset(, 0)
Set Src2 = .Offset(, 1)
Set Src3 = .Offset(, 2)
End With
Set Target = Range("L1")
Transfer Src1, Src2, Src3, Target
MsgBox Format(Timer – TG, "0.000000000")
End SubVới dữ liệu 60.000 dòng thì code của em nhanh gấp đôi của sư phụ đó nha
Em nghĩ code của sư phụ bị chậm đi là do có thằng SUMPRODUCT (còn của em chỉ định vị rồi cộng dồn)

http://www.giaiphapexcel.com/diendan/threads/l%E1%BA%A5y-dm-duy-nh%E1%BA%A5t-theo-2-c%E1%BB%99t-scripting-dictionary.37895/post-254754

Bài toán ở đây là:

– Có n công ty bán hàng, mỗi công ty có thể cung cấp từ 1 đến m mặt hàng trong số m mặt hàng mà ta có nhu cầu. Giá cả của từng công ty đối với mỗi mặt hàng là khác nhau. (Cũng có thể giống nhau).
– Như vậy chuỗi ghép "công ty n" & "dịch vụ m" là duy nhất (dữ liệu mẫu trong file của ndu do copy xuống nên không duy nhất)

Người ta muốn liệt kê thành bảng 2 chiều để dễ truy xuất công ty x, mặt hàng y, giá bao nhiêu. Đại khái như file kèm theo (15.750 companies, 4 services.)

Chính vì vậy nên mình dùng sumproduct, vì chưa có ý hay hơn.
Dùng thủ thuật biến 1 chiều thành 2 chiều không được, kể cả sau khi sort, vì có công ty chỉ bán 1, 2, 3 mặt hàng trong số 4 mặt hàng cần dùng.

Note: Với 60.000 dòng thì cả 2 code đều làm đơ máy

Ẹc… Ẹc…
Với file mới của sư phụ, em cải tiến code lại tí xíu, ra kết quả trong vòng chưa đầy 2s
Hồi trưa do sơ ý nên em đã dùng MATCH, giờ em sửa lại vầy:

Sub Transfer(Src1 As Range, Src2 As Range, Src3 As Range, Target As Range)
Dim Arr(1 To 60000, 1 To 200), ScrArr1, SrcArr2, SrcArr3, Dic1, Dic2, Tmp1, Tmp2
Dim i As Long, iR As Long, iC As Long
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
ScrArr1 = Src1.Value
SrcArr2 = Src2.Value
SrcArr3 = Src3.Value
iR = 1: iC = 1
For i = 1 To UBound(ScrArr1)
If ScrArr1(i, 1) <> "" And SrcArr2(i, 1) <> "" Then
Tmp1 = ScrArr1(i, 1): Tmp2 = SrcArr2(i, 1)
If Not Dic1.Exists(Tmp1) Then
iR = iR + 1
Dic1.Add Tmp1, iR
Arr(iR, 1) = Tmp1
End If
If Not Dic2.Exists(Tmp2) Then
iC = iC + 1
Dic2.Add Tmp2, iC
Arr(1, iC) = Tmp2
End If
Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp2)) = _
Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp2)) + SrcArr3(i, 1)
End If
Next i
Target.Resize(iR, iC).Value = Arr
End Sub
Sub Main()
Dim Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, TG As Double
TG = Timer
With Range(, .End(xlUp))
Set Src1 = .Offset(, 0)
Set Src2 = .Offset(, 1)
Set Src3 = .Offset(, 2)
End With
Set Target = Range("L1")
Transfer Src1, Src2, Src3, Target
MsgBox Format(Timer – TG, "0.000000000")
End Sub
Xin sư phụ cho biết ý kiến
(Sư phụ có thể yên tâm về tính chính xác của kết quả, vì em đã dùng PivotTable để kiểm chứng)

Reply
hands says:

31/12/2022 at 11:06 pm

Anh dùng Sumproduct với dữ liệu lớn như vầy thì treo máy là chắc. Làm em test treo máy 3 lần.

Lê Văn Duyệt

Match, Index, cũng tiêu luôn. Hìhì! Đã nói là đơ máy mà còn test 3 lần.

Xin sư phụ cho biết ý kiến
(Sư phụ có thể yên tâm về tính chính xác của kết quả, vì em đã dùng PivotTable để kiểm chứng)

Còn ý kiến gì khác chứ? Quá tuyệt!

Trong khi chờ, mình dùng phép chuyển 1 chiều thành 2 chiều có điều kiện, nhanh hơn của ndu, nhưng bị lỗi:

Nếu công ty 00001 chỉ có 3 loại dịch vụ B, C, D, tiếp theo công ty 00002 có bao nhiêu loại dịch vụ không cần biết, nhưng có loại A, nghĩa là A nằm dưới B, C, D trong Dic2, thì kết quả sai.
Nếu công ty 00001 chỉ có 3 loại dịch vụ A, B, C, tiếp theo công ty 00002 có bao nhiêu loại dịch vụ không cần biết, nhưng có loại D, nghĩa là Dict2 có thứ tự A, B, C, D, thì kết quả đúng

Trong file đính kèm, để nguyên test thì nhanh hơn ndu, và đúng. Nhưng xoá dòng thứ 2 (Service A), thì cũng vẫn nhanh, nhưng kết quả sai. Chán thế! Sửa mãi chưa được.
Cải tiến code:
– Dùng cú pháp gán giá trị vào các cột prices của ndu (không dùng thủ thuật chuyển 1 chiều thành 2 chiều, hết lỗi)
– 1 vòng lặp duy nhất
– Vẫn gán xuống sheet 3 lần, trong đó 2 lần dùng Dictionary.Keys (không dùng mảng)
– Tốc độ nhanh hơn.

Nói thêm: Đây là 1 câu hỏi của 1 thành viên EcelHelp Forum hỏi qua tin nhắn PM. Do cầu toàn nên mình test đủ kiểu và cải tiến tốc độ (test với 60.000 dòng), sự thực theo suy đoán thì không quá 50 companies và 10 services

Xin cám ơn ndu. Link bài trả lời bên Excel help forum: [URL='https://www.excelforum.com/excel-programming/737711-convert-1-dimension-data-to-2-dimensions.html#post2346038']https://www.excelforum.com/excel-pro…mension-data-to-2-dimensions.html#post2346038

Tải file [URL='https://www.mediafire.com/file/l0961a911a3r9co/ScriptingDictionary4.rar'%5Dtại đây.

Nguyên nhân vì:
– Lý ra sư phụ phải xét điều kiện <> "" cho 2 mảng trước, sau đó mới xét tính tồn tại
– Sư phụ viết vầy:

If dArr1(i, 1) <> "" And Not MyDic1.Exists(dArr1(i, 1)) Then
…
End If
If dArr2(i, 1) <> "" And Not MyDic2.Exists(dArr2(i, 1)) Then
…
End If
– Mà theo em phải vầy mới ổn

If dArr1(i, 1) <> "" And dArr2(i, 1) <> "" Then
If Not MyDic1.Exists(dArr1(i, 1)) Then
…
End If
If Not MyDic2.Exists(dArr2(i, 1)) Then
…
End If
End If

Phần đó thì lại ổn, Dic1, Dic2 đều đúng và đủ. Dict1 là cột ngoài cùng bên trái, Dic2 là dòng đầu bên trên.

Cái sai nằm ở vòng lặp sau cùng nhắm lấy các giá trị cột Price nhét vào Array 2 chiều:

k = 1
For i = 1 To MyDic1.Count
For j = 1 To MyDic2.Count
If dArr1(k, 1) = Arr1(i, 1) And dArr2(k, 1) = Arr2(j, 1) Then
dPrice(i, j) = dArr3(k, 1)
k = k + 1
Else
dPrice(i, j) = ""
End If
Next j, i

Khi i chạy 1 hoặc 2 dòng đầu (vừa đủ cho Dict2 lấp đầy 4 service), kết quả còn đúng.
Khi i chạy xuống dòng kế:
Khi j chạy qua 1 lượt B, C, D, A, (thứ tự không đúng), giả sử thấy A trước rồi thì đã qua khỏi B, C, D rồi. Đến khi thấy B thì không quay lại được mà nhảy xuống dòng dưới là Company khác => điễu kiện không thoả => sai. Sai dắt dây toàn bộ những dòng dưới.

Chỉ có dùng Dic2.Item(Arr2(i,1) mới gán đúng chỗ, và đồng thời không cho j chạy theo cột nữa.

Code của bác Mỹ không cộng dồn. Bác thử copy Company 00001 xuống vài dòng sẽ thấy.
Còn của NDU có cộng dồn.

Theo quy ước dữ liệu thì không có trùng: 1 công ty, 1 mặt hàng, chỉ có 1 giá. Copy xuống thì nghĩa là 1 công ty bán cùng 1 mặt hàng mà lại có nhiều giá? Không bao giờ.

Nếu 1 người bán báo giá nhiều giá, thì đã có những điều kiện kèm theo như: mức mua tối thiểu, phương thức và thời hạn thanh toán, …
Lúc này dữ liệu không chỉ 3 cột.

Mà giả sử 2 giá (giả sử thôi), thì liệt kê hoặc lấy bình quân, chứ ai lại cộng dồn.

Vậy thì em kết hợp của Bác PTM và NDU làm lại code trên. Thấy có vẻ nhanh hơn.
Sub Convert2()
Dim TG As Double
Dim i As Long, endR As Long, j As Long, s As Long, t As Long
Dim dArr(), dPrice(1 To 65536, 1 To 10)
Dim MyDic1 As Object, MyDic2 As Object
TG = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
dArr = .Range("A2:C" & endR).Value
End With
Set MyDic1 = CreateObject("scripting.dictionary")
Set MyDic2 = CreateObject("scripting.dictionary")
For i = 1 To endR – 1 'UBound(dArr)'
If Len(Trim(dArr(i, 1))) > 0 Then
If Not MyDic1.Exists(dArr(i, 1)) Then
s = s + 1
dPrice(s, 1) = dArr(i, 1)
MyDic1.Add dArr(i, 1), s
End If
End If
If Len(Trim(dArr(i, 2))) > 0 Then
If Not MyDic2.Exists(dArr(i, 2)) Then
t = t + 1
MyDic2.Add dArr(i, 2), t
End If
End If
dPrice(s, MyDic2.Item(dArr(i, 2)) + 1) = dArr(i, 3)
Next
Sheet1..Resize(s, t + 1).Value = dPrice
Sheet1..Resize(1, t).Value = MyDic2.Keys
Set MyDic1 = Nothing
Set MyDic2 = Nothing
Erase dArr, dPrice
MsgBox Format(Timer – TG, "0.000000000") & " seconds"
End Sub

Giải thuật thì đã có rồi! Còn cách viết code theo tôi thì:
– Nên tạo 1 sub có tham số truyền, mục đích để tùy biến thoải mái khi dùng (vì dữ liệu trên từng máy đâu phải lúc nào cũng là cột A và C)
– Nên chia làm 3 mảng riêng biệt, vì thực tế đâu phải lúc nào 3 cột này cũng nằm gần nhau (ví dụ Company tại cột A, services ở cột D còn price thì nằm tận cột W)

Bây giờ cũng bài toán trên, một yêu cầu khác là lấy:
1/ Giá trị trung bình theo từng company – Ser
2/ Lấy max hay min.
Nhờ các bác triển khai giúp.

Trong 3 yêu cầu trên, mình nghĩ tìm MAX là dễ nhất

If Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp2)) < SrcArr3(i, 1) Then _
Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp2)) = SrcArr3(i, 1)Còn MIN và AVERAGE thì…Ẹc… Ẹc… chẳng dễ nhai tí nào —> Có lẽ phải thêm 1 mảng phụ nữa chăng?
Hôm nay rảnh rổi ta quay lại để tài này
Thật ra cũng chỉ dợt thuật toán, chứ mấy chiêu tổng hợp này PivotTable cho tốc độ ăn đứt

Sub Transfer(Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, SummaryType As String)
Dim Arr(1 To 60000, 1 To 200), ScrArr1, SrcArr2, SrcArr3, Dic1, Dic2, Tmp1, Tmp2
Dim i As Long, iR As Long, iC As Long, n As Long, m As Long
Dim TmpArr1(1 To 60000, 1 To 200), TmpArr2(1 To 60000, 1 To 200)
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
ScrArr1 = Src1.Value
SrcArr2 = Src2.Value
SrcArr3 = Src3.Value
iR = 1: iC = 1
For i = 1 To UBound(ScrArr1)
If ScrArr1(i, 1) <> "" And SrcArr2(i, 1) <> "" Then
Tmp1 = ScrArr1(i, 1): Tmp2 = SrcArr2(i, 1)
If Not Dic1.Exists(Tmp1) Then
iR = iR + 1
Dic1.Add Tmp1, iR
Arr(iR, 1) = Tmp1
End If
If Not Dic2.Exists(Tmp2) Then
iC = iC + 1
Dic2.Add Tmp2, iC
Arr(1, iC) = Tmp2
End If
n = Dic1.Item(Tmp1)
m = Dic2.Item(Tmp2)
Select Case SummaryType
Case Is = "Min"
If Arr(n, m) = "" Or Arr(n, m) > SrcArr3(i, 1) Then Arr(n, m) = SrcArr3(i, 1)
Case Is = "Max"
If Arr(n, m) < SrcArr3(i, 1) Then Arr(n, m) = SrcArr3(i, 1)
Case Is = "Sum"
Arr(n, m) = Arr(n, m) + SrcArr3(i, 1)
Case Is = "Average"
TmpArr1(n, m) = TmpArr1(n, m) + 1
TmpArr2(n, m) = TmpArr2(n, m) + SrcArr3(i, 1)
Arr(n, m) = TmpArr2(n, m) / TmpArr1(n, m)
End Select
End If
Next i
Target.Resize(iR, iC).Value = Arr
End Sub
Sub Main()
Dim Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, TG As Double
TG = Timer
With Range(, .End(xlUp))
Set Src1 = .Offset(, 0)
Set Src2 = .Offset(, 1)
Set Src3 = .Offset(, 2)
End With
Set Target = Range("F2")
Transfer Src1, Src2, Src3, Target, .Value
MsgBox Format(Timer – TG, "0.000000000")
End SubCode này tổng hợp theo 4 kiểu: Max, Min, Sum và Average
Các bạn xem file và kiểm tra độ chính xác nhé (dùng PivotTable để kiểm tra chẳng hạn)

Reply