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

ThuNghi · 5/7/10

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é.
Cám ơn nhiều.

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

ptm0412 · 19/7/10

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ờ.

ptm đã viết:
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.

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.

ThuNghi · 19/7/10

ptm0412 đã viết:
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.

PHP:

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.[U2].Resize(s, t + 1).Value = dPrice
    Sheet1.[V1].Resize(1, t).Value = MyDic2.Keys
    Set MyDic1 = Nothing
    Set MyDic2 = Nothing
    Erase dArr, dPrice
    MsgBox Format(Timer - TG, "0.000000000") & " seconds"
End Sub

ndu96081631 · 19/7/10

ThuNghi đã viết:
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.

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)

ThuNghi · 20/7/10

ndu96081631 đã viết:
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.

ndu96081631 · 20/7/10

ThuNghi đã viết:
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

PHP:

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?

ndu96081631 · 20/8/10

ThuNghi đã viết:
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.

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

PHP:

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

PHP:

Sub Main()
  Dim Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, TG As Double
  TG = Timer
  With Range([A2], [A65536].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, [E1].Value
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Code 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)

thuyyeu99 · 24/10/10

Cái này em muốn nó thể hiện Service 1 theo dạng cột thì làm sao anh.
Ví dụ:

Company 01

| Service 1

| 1054911.3

|
|

Service 2

|

1,065,419.75

|
|

Service 3

|

1,077,214.06

|

Company 02

|

Service 2

|

1,028,314.26

|
|

Service 3

|

1,046,352.3

|

ndu96081631 · 24/10/10

thuyyeu99 đã viết:
Cái này em muốn nó thể hiện Service 1 theo dạng cột thì làm sao anh.
Ví dụ:

Company 01
| Service 1
| 1054911.3
|
|
Service 2
|
1,065,419.75
|
|
Service 3
|
1,077,214.06
|

Company 02
|
Service 2
|
1,028,314.26
|
|
Service 3
|
1,046,352.3
|

Cái này PivotTable ra ngay kết quả, cần gì suy nghĩ:

ThuNghi · 24/10/10

thuyyeu99 đã viết:
Cái này em muốn nó thể hiện Service 1 theo dạng cột thì làm sao anh.
Ví dụ:

Company 01

| Service 1

| 1054911.3

|
|
Service 2
|
1,065,419.75
|
|
Service 3
|
1,077,214.06
|

Company 02
|
Service 2
|
1,028,314.26
|
|
Service 3
|
1,046,352.3
|

Em tự nghiên cứu thêm thử, thay vì tìm duy nhất theo từng tmp thì mình tìm theo.

Tmp1 = ScrArr1(i, 1): Tmp2 = SrcArr2(i, 1)
If Not Dic1.Exists(Tmp1) Then

tmp=tmp1&tmp2
If Not Dic1.Exists(Tmp) Then
'...

thuyyeu99 · 25/10/10

Dạ không em mượn cái ví dụ của anh thôi chứ File em không áp dụng PivotTable Ạh. Với lại đoạn code này giúp em giải quyết được một số vấn đề liên quan khác nữa..(Code em tự viết nó chạy hơi chậm và rườm rà quá)

Em tự nghiên cứu thêm thử, thay vì tìm duy nhất theo từng tmp thì mình tìm theo.
Tmp1 = ScrArr1(i, 1): Tmp2 = SrcArr2(i, 1)
If Not Dic1.Exists(Tmp1) Then

tmp=tmp1&tmp2
If Not Dic1.Exists(Tmp) Then
'...

Dạ em cũng có làm thử rồi nhưng phần Array và CreateObject("Scripting.Dictionary") em dang tập, em chưa hiểu nó lắm.

thuyyeu99 · 3/11/10

Trà công nhậnScripting.dictonary và Array hay thiệt từ cái thuật toán của anh ndu96081631 thêm chút xíu nữa là thay cho hàm SumIfs (4 Đk) trong 2007 chạy ngon lành thiệt. từ 4,273437500 còn 1,576562500 S

Cám ơn anh ThuNghi và ndu96081631 nhiều.

thuyyeu99 · 3/4/11

Các anh chạy code nó có báo lỗi "Run - time Error 7 .Out of memory" Không, sao nhiều lúc em chạy code nó lại báo lỗi ? +-+-+-+

trungvdb · 12/2/12

ndu96081631 đã viết:
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à đủ

Cái bước Nối 2 cột lại thành 1 biến tạm, là Tmp nhằm mục đích gì nhỉ?

ndu96081631 · 12/2/12

trungvdb đã viết:
Cái bước Nối 2 cột lại thành 1 biến tạm, là Tmp nhằm mục đích gì nhỉ?

Đã nói là lọc duy nhất 2 cột mà
Ví dụ

Thì dòng 1 và dòng 4 trùng nhau ---> Để biết nó có trùng không, ta nối 2 cột lại rồi Add vào Dic...
Nếu không làm vậy thì bạn sẽ làm sao?

anhtuan1069 · 11/5/17

ndu96081631 đã viết:

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

PHP:

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

PHP:

Sub Main()
  Dim Src1 As Range, Src2 As Range, Src3 As Range, Target As Range, TG As Double
  TG = Timer
  With Range([A2], [A65536].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, [E1].Value
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Code 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)

Thầy NDU xem giúp em code này sau bị lỗi tràn bộ nhớ khi gọi hàm transfer

basao · 24/10/23

Em xin nhờ các anh, chị giúp em bài tổng hợp này code với ạ
Mục đích của bài là muốn cố định cột điều kiện, dòng điều kiện ở sheet Kiem_tra của file báo cáo.
Dò lọc trùng, đếm tổng hợp từ bảng dữ liệu sheet Kiem_tra của file dữ liệu. Ghi kết quả sang sheet Kiem_tra file báo cáo.
Em có gửi kèm bài sử dụng hàm của anh HUONGLIEN đã giúp em.
Em cảm ơn ạ!

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

Hãy cho rồi sẽ nhận!

Bad Excel Member

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

Huyền thoại GPE

File đính kèm

Trùm Nhiều Chuyện

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Trùm Nhiều Chuyện

Trùm Nhiều Chuyện

Trùm Nhiều Chuyện

Thành viên thường trực

Huyền thoại GPE

Thành viên mới

Thành viên mới

File đính kèm

Đếm ngược thời gian