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

Liên hệ QC
T

ThuNghi

Hãy cho rồi sẽ nhận!
Thành viên đã mất
Tham gia
16/8/06
Bài viết
3,808
Được thích
4,449
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
Nhấp chuột vào đây để mở rộng...
 
Sắp xếp theo thời gian sắp xếp theo bầu chọ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ờ.

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.
Nhấp chuột vào đây để mở rộng...

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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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)
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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?
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộ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
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)
 

File đính kèm

  • TransferData_3.rar
    730.1 KB · Đọc: 382
Upvote 0
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​
|
 
Lần chỉnh sửa cuối:
Upvote 0
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​
|
Nhấp chuột vào đây để mở rộng...
Cái này PivotTable ra ngay kết quả, cần gì suy nghĩ:

untitled.JPG
 
Upvote 0
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​
|
Nhấp chuột vào đây để mở rộng...
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
Nhấp chuột vào đây để mở rộng...
tmp=tmp1&tmp2
If Not Dic1.Exists(Tmp) Then
'...
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
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
'...
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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 ?+-+-+-+
 
Upvote 0
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à đủ
Nhấp chuột vào đây để mở rộng...

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ỉ?
 
Upvote 0
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ỉ?
Nhấp chuột vào đây để mở rộng...
Đã nói là lọc duy nhất 2 cột mà
Ví dụ

Capture.JPG

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?
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
Thầy NDU xem giúp em code này sau bị lỗi tràn bộ nhớ khi gọi hàm transferupload_2017-5-11_14-31-0.png
 
Upvote 0
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 ạ!
 

File đính kèm

  • Nho GPE giup.rar
    43.9 KB · Đọc: 4
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
xin công thức tính kết chuyển lỗ vào thu nhập tính thuế TNDN trong nhiều năm
Trả lời
1
Đọc
49
HieuCD
H
solomon2211
PDF Tools giúp ghép, tách, xóa file pdf
    • Thích
    • Yêu thích
Trả lời
11
Đọc
245
YêuCN
Y
LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
    • Cười
2 3
Trả lời
50
Đọc
1K
SA_DQ
SA_DQ
Bùi Đức Dương
Vba sang Vb.net
Trả lời
4
Đọc
158
VetMini
V
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
27
Đọc
438
ann266
ann266
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom