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: 388
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

H
  • Question
Xóa toàn bộ các dòng giống nhau ở 1 cột
    • Cười
Trả lời
1
Đọc
8
BuiQuangThuan
B
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
8
Đọc
432
Duy Tùng 9x
Duy Tùng 9x
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
163
Đọc
8K
trannguyen197
T
Manhhung90
Liệt kê các ngày cộng dồn mong muốn vào 1 ô. Nhờ mọi người giúp mình ạ.
2 3 4
Trả lời
61
Đọc
712
huuthang_bd
huuthang_bd
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
12
Đọc
202
vova2209
vova2209
tvcneo
  • Question
Nhờ Anh Chị Em giúp mình cách để tạo macro giống như trong file này
Trả lời
17
Đọc
217
huuthang_bd
huuthang_bd
T
Có phải lỗi Excel?
Trả lời
8
Đọc
9K
dinhthang8709
D
T
Công thức lấy dữ liệu
Trả lời
3
Đọc
112
HUONGHCKT
H
S
  • Question
Nhờ anh chị giúp em hàm ngẫu nhiên với tổng là 1 số
Trả lời
6
Đọc
145
SA_DQ
SA_DQ
O
  • Question
Tìm số thứ tự của sheet trong workbook có nhiều sheets
Trả lời
10
Đọc
3K
Hoàng Tuấn 868
H
L
Tự động nhảy số tham chiếu khi sang sheet mới
Trả lời
5
Đọc
5K
Romantic92
R
TieuLong2708
Danh sách lịch cắt người trực
Trả lời
0
Đọc
36
TieuLong2708
TieuLong2708
C
  • Question
Xin giúp đỡ Code kiểm tra và copy dữ liệu từ sheet 1 sang sheet 2
2
Trả lời
21
Đọc
625
conan1
C
H
  • Question
Mong giúp code chuyển file xls sang xlsx hàng loạt và không lỗi số liệu
Trả lời
16
Đọc
368
Hoàng Tuấn 868
H
jenny12345
tổng hợp dữ liệu theo tháng
Trả lời
10
Đọc
245
Hoàng Tuấn 868
H
S
Trợ giúp công thức lấy dữ liệu
Trả lời
7
Đọc
132
Hoàng Tuấn 868
H
M
Không gõ được tiếng Việt trên Excel
Trả lời
4
Đọc
116
MKC
M
H
Có thể mở file Excel mới sẽ Zoom mặc định 150% không?
Trả lời
3
Đọc
145
hieug126
H
hieuxd
Tặng File mẫu tính cao độ truyền nhiều trạm máy và nhiều mốc cao độ
    • Thích
    • Cảm ơn
Trả lời
9
Đọc
12K
QTCD2
Q
Hai Lúa Miền Tây
  • Question
Hàm groupby và pivot_table của Python trong Excel
    • Thích
    • Yêu thích
Trả lời
15
Đọc
595
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

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