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

ndu96081631 · 5/7/10

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

Thử vầy xem:

PHP:

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(.[A2], .[A65536].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ả

ThuNghi · 5/7/10

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.

PHP:

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

ndu96081631 · 5/7/10

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

đoạn này:

PHP:

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?

ThuNghi · 5/7/10

ndu96081631 đã viết:
đoạn này:

PHP:

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ể mình đ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.

ndu96081631 · 5/7/10

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

ThuNghi · 5/7/10

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 đã.

PHP:

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.

ndu96081631 · 5/7/10

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

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

-------------------------------------------------

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

PHP:

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:

PHP:

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

sealand · 5/7/10

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

Mã:

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.

ptm0412 · 18/7/10

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

PHP:

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 = [a65000].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.[f1].Resize(MyDic1.Count, 1).Value = Application.Transpose(MyDic1.keys)
    Sheet1.[g1].Resize(1, MyDic2.Count).Value = MyDic2.keys
    
Set PriceRng = Sheet1.[f1].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.

ndu96081631 · 18/7/10

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

PHP:

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

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("L1")
  Transfer Src1, Src2, Src3, Target
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Vớ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)

ptm0412 · 18/7/10

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

ndu96081631 · 18/7/10

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

PHP:

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

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("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)

levanduyet · 18/7/10

ptm0412 đã viết:
Chính vì vậy nên mình dùng sumproduct, vì chưa có ý hay hơn.

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

ndu96081631 · 18/7/10

Ah... quên lưu ý với mọi người: Tải file về nhớ giải nén ra rồi hẳn chạy nhé ---> Chẳng hiểu sao nếu để nguyên trong file RAR mà chạy thì tốc độ sẽ rất chậm!

ptm0412 · 18/7/10

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

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

ptm0412 · 19/7/10

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: http://www.excelforum.com/excel-pro...mension-data-to-2-dimensions.html#post2346038

Tải file tại đây.

ndu96081631 · 19/7/10

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

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:

PHP:

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

PHP:

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

ptm0412 · 19/7/10

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

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:

PHP:

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.

ThuNghi · 19/7/10

ptm0412 đã viết:
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: http://www.excelforum.com/excel-pro...mension-data-to-2-dimensions.html#post2346038

Tải file tại đây.

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.

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

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

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

Thành viên gạo cội

Bad Excel Member

File đính kèm

Huyền thoại GPE

File đính kèm

Bad Excel Member

File đính kèm

Huyền thoại GPE

File đính kèm

Hãy để gió cuốn đi.

Huyền thoại GPE

Bad Excel Member

File đính kèm

Bad Excel Member

Huyền thoại GPE

Bad Excel Member

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