Nhờ hướng dẫn sử dụng Dictionary Object. (1 người xem)

TrungChinhs · 20/11/10

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

ptm0412 · 21/11/10

Ngoài các mảng đang dùng, anh dùng thêm 1 mảng nhiều cột đồng thời với Dic:
Khi điều kiện duy nhất (dựa vào Dic.Exist ...) thỏa, add 1 item vào Dic, đồng thời add toàn bộ dòng dữ liệu thỏa đk đó vào mảng.

TrungChinhs · 21/11/10

ptm0412 đã viết:
Ngoài các mảng đang dùng, anh dùng thêm 1 mảng nhiều cột đồng thời với Dic:
Khi điều kiện duy nhất (dựa vào Dic.Exist ...) thỏa, add 1 item vào Dic, đồng thời add toàn bộ dòng dữ liệu thỏa đk đó vào mảng.

Cảm ơn Ptm0412 đã chỉ dẫn nhưng do tôi chưa thạo về món này nên cả ngày hôm nay đánh vật với bài này mà vẫn không làm được.

Nhờ các bạn viết giúp code cho file đính kèm với Yêu cầu là Lọc duy nhất cả dòng từ các Sheet về Sheets TongHop.

Thanks !

ndu96081631 · 21/11/10

Trung Chinh đã viết:
Cảm ơn Ptm0412 đã chỉ dẫn nhưng do tôi chưa thạo về món này nên cả ngày hôm nay đánh vật với bài này mà vẫn không làm được.

Nhờ các bạn viết giúp code cho file đính kèm với Yêu cầu là Lọc duy nhất cả dòng từ các Sheet về Sheets TongHop.

Thanks !

Tức là vầy nè anh ơi:

PHP:

Sub TongHopSh()
  Dim Dic, Sh As Worksheet, Cls As Range, i As Long, Arr()
  On Error Resume Next
  Sheets("TongHop").Range("C6:F60000").ClearContents
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each Sh In Worksheets
    If Sh.Name <> "TongHop" And Sh.Name <> "DM" Then
      For Each Cls In Sh.Range(Sh.[C6], Sh.[C65536].End(xlUp))
        If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then
          Dic.Add Cls.Value, ""
          i = i + 1
          ReDim Preserve Arr(1 To 4, 1 To i)
          Arr(1, i) = Cls.Offset(, 0).Value
          Arr(2, i) = Cls.Offset(, 1).Value
          Arr(3, i) = Cls.Offset(, 2).Value
          Arr(4, i) = Cls.Offset(, 3).Value
        End If
      Next
    End If
  Next
  Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
End Sub

If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then

Kiểm tra xem Cls có rổng không, đồng thời kiểm tra xem giá trị Cls đã tồn tại trong Dic hay chưa

Dic.Add Cls.Value, ""
i = i + 1
ReDim Preserve Arr(1 To 4, 1 To i)
Arr(1, i) = Cls.Offset(, 0).Value
Arr(2, i) = Cls.Offset(, 1).Value
Arr(3, i) = Cls.Offset(, 2).Value
Arr(4, i) = Cls.Offset(, 3).Value

Nếu điều kiện IF thỏa mản, ta Add giá trị Cls vào Keys của Dic, đồng thời Add từng cell trong cùng dòng với Cls vào Array
Đơn giản vậy thôi!
Khi này, Dictionary chỉ dùng để kiểm tra sự tồn tại của biến chạy chứ ta không lấy nó để xuất kết quả (có lấy cũng không được vì cùng lắm chỉ được 2 cột)
-----------------
Code của anh dùng UsedRange đôi lúc không tốt bằng End(xlUp) đâu ---> Vì có khi nó quá thừa dòng, thừa cột

ptm0412 · 21/11/10

1. Chưa thấy anh dùng mảng song song?
2. Dùng mảng để gán giá trị từng sheet sau đó dò trong mảng sẽ nhanh hơn dò trên sheet.
3. Mảng song song là ArrKetqua, thiết lập sẵn 1000 dòng 4 cột. Tuy nhiên khi gán kết quả xuống sheet chỉ gán vừa đủ (Dic.Count)

PHP:

Option Base 1
____________________________

Sub TongHopSh()

    Dim sh, Dic, iRow, cls, RowsCount
    Dim ArrSh(), ArrKetqua(1000, 4)
    With Sheets("TongHop")
       .[b6].Resize(.UsedRange.Rows.Count, 4).ClearContents

       Set Dic = CreateObject("Scripting.Dictionary")
       For Each sh In Worksheets
            If sh.Name <> "TongHop" And sh.Name <> "DM" Then
                RowsCount = sh.[c65000].End(xlUp).Row - 5
                ReDim ArrSh(RowsCount, 4)
                ArrSh = sh.[c6].Resize(RowsCount, 4).Value
                For i = 1 To RowsCount
                   If Not Dic.exists(ArrSh(i, 1)) Then
                        Dic.Add ArrSh(i, 1), ""
                        iRow = iRow + 1
                        For j = 1 To 4
                            ArrKetqua(iRow, j) = ArrSh(i, j)
                        Next
                    End If
                Next
                'Erase ArrSh
            End If
      Next
        .[c6].Resize(Dic.Count, 4) = ArrKetqua
    
    End With
End Sub

ndu không dùng mảng cho từng sheet, và vì tính chất của redim preserve nên ăn gian transpose mảng?

TrungChinhs · 21/11/10

Cảm ơn Ndu và Ptm0412 ! Tôi đã test và thấy code của các bạn đều OK.

Sau khi xem qua mới hiểu tại sao mình làm mãi mà không ra (ngoài sự hiểu biết của tôi). Trong code có nhiều câu Tôi vẫn chưa hiểu nhưng sẽ cố gắng nghiên cứu tiếp. Nếu gì khó khăn tôi sẽ hỏi tiếp, mong các bạn quan tâm giúp đỡ.

P/s các bạn giải thích giúp câu nhận xét của Ptm0412 (câu màu đỏ trong trích dẫn)

ndu không dùng mảng cho từng sheet, và vì tính chất của redim preserve nên ăn gian transpose mảng?

ptm0412 · 21/11/10

ReDim mảng thông thường thì xóa dữ liệu cũ của mảng. Redim Preserve thì bảo toàn dữ liệu. Tuy nhiên VBA quy định chỉ bảo toàn dữ liệu khi thay đổi kích thước chiều cuối cùng của mảng: tức là chỉ được thay đổ số cột, không thay đổi số dòng. Do đó ndu ăn gian, sử dụng mảng Arr ngang (cột thành dòng, dòng thành cột), để có thể ReDim Preserve, Cuối cùng ra kết quả rồi thì transpose mảng trước khi gán xuống sheet.

Còn code của tôi không dùng ReDim Preserve vì tôi đã ReDim ArrKetqua trừ hao 1000 dòng ngay từ đầu, không có dữ liệu để mất. Còn ArrSh, khi đổi sheet thì dữ liệu mới, cần thiết phải xóa dữ liệu cũ trong mảng, nên tôi lại dùng Redim mà không ReDim Preserve.

ndu96081631 · 21/11/10

Trung Chinh đã viết:
P/s các bạn giải thích giúp câu nhận xét của Ptm0412 (câu màu đỏ trong trích dẫn)

ndu không dùng mảng cho từng sheet, và vì tính chất của redim preserve nên ăn gian transpose mảng?

Nhấp chuột vào đây để mở rộng...

Chính xác là thế, để tăng tốc độ cho code, lý ra khi duyệt qua các sheet, lấy được vùng dữ liệu, ta gán vùng ấy vào 1 mảng luôn. Có điều em lượt bớt để anh dễ hiểu thôi (khi nào có nhu cầu mới tính tiếp)
Cụ thể ở chổ này: ArrSh = sh.[c6].Resize(RowsCount, 4).Value <--- Đây chính là 1 mảng
Có điều sư phụ dùng câu lệnh trước: ReDim ArrSh(RowsCount, 4) <--- Cái này thừa... vì cho dù có ReDim thế nào đi chăng, sau khi gán ArrSh = sh.[c6].Resize(RowsCount, 4).Value thì ArrSh cũng sẽ có kích thước đúng bằng với vùng sh.[c6].Resize(RowsCount, 4) mà thôi
Có thể thí nghiệm để kiểm chứng:

PHP:

Sub Test()
  Dim Arr()
  ReDim Arr(1 To 10, 1 To 5)
  Arr = Range("A1:C3").Value
  MsgBox UBound(Arr, 1) & " - " & UBound(Arr, 2)
End Sub

ReDim 2 chiều là 10 và 5 phần tử ---> Sau khi gán xong nó vẫn là 3 - 3, đúng = kích thước của Range("A1:C3") (chứ không phải là 10 - 5)
------------------------------------------------
Ngoài ra, vì sư phụ không dùng TRANSPOSE nên buộc phải khai báo mảng ArrKetqua thừa ra 1 chút ----> ArrKetqua(1000, 4) tương đương 1000 phần tử chiều thứ nhất và 4 phần tử chiều thứ 2 ---> mường tượng giống như 1 vùng dữ liệu 1000 dòng, 4 cột ---> Điều này có 2 mặt ưu khuyết:
- Ưu điểm: Khỏi cần TRANSPOSE khi đặt kết quả cuối cùng
- Khuyết điểm: Nếu dữ liệu nhiều, đồng thời số phần tử trùng nhiều thì cách này cho tốc độ chậm hơn so với TRANSPOSE ---> Đã thí nghiệm 60,000 dòng mổi sheet, trong đó chỉ có 50 phần tử duy nhất thì cách dùng TRANSPOSE cho kết quả trong thời gian 0.6s, còn cách ReDim dư ra như sư phụ cho kết quả = 0.9s
Yên tâm rằng hàm TRANSPOSE chẳng làm chậm quá trình tính toán đi tí nào (nếu có cũng là cực nhỏ)
Cách mà em làm, nếu tính luộn đến việc tăng tốc thì sẽ vầy:

PHP:

Sub TongHopSh()
  Dim Dic, sh As Worksheet, iRow As Long, i As Long, Arr(), TmpArr, Tmp, TG As Double
  On Error Resume Next
  TG = Timer
  Application.ScreenUpdating = False
  Sheets("TongHop").Range("C6:F60000").ClearContents
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each sh In Worksheets
    If sh.Name <> "TongHop" And sh.Name <> "DM" Then
      TmpArr = sh.Range(sh.[c6], sh.[C65536].End(xlUp)).Resize(, 4).Value
      For iRow = 1 To UBound(TmpArr, 1)
        If Not IsEmpty(TmpArr(iRow, 1)) Then
          Tmp = TmpArr(iRow, 1)
          If Not Dic.Exists(Tmp) Then
            Dic.Add Tmp, ""
            i = i + 1
            ReDim Preserve Arr(1 To 4, 1 To i)
            Arr(1, i) = TmpArr(iRow, 1)
            Arr(2, i) = TmpArr(iRow, 2)
            Arr(3, i) = TmpArr(iRow, 3)
            Arr(4, i) = TmpArr(iRow, 4)
          End If
        End If
      Next
    End If
  Next
  Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
  Application.ScreenUpdating = True
  MsgBox Timer - TG
End Sub

------------------------------------------------
Vì mảng nó hơi trừu tượng nên e rằng anh phải "cày" thật kiên nhẩn mới mong tiếp cận và tùy biến được

sealand · 21/11/10

Mình tham gia 1 vài ý kiến:
1/ Vạn bất đắc dĩ mới dùng On error resume next, như vậy nó cũng nhảy qua lỗi không phải là trùng key. Ta sử dụng phương thức Exists mà Dictionary hỗ trợ mới hay.
2/Dictionay không gò buộc Items thì vậy sao ta không sử dụng Key như vé gửi hàng , còn Items như thùng hàng

Giải quyết như trên là thuần Dic. không phải thêm nhiếu code trung gian khác

Bạn tham khảo đoạn code mình Modify như sau:

Mã:

Sub TongHopSh()
  Dim a, b, i, Dic, It, sh As Worksheet, Cls As Range
    Application.ScreenUpdating = 0
     With Sheets("TongHop")
       .[b6].Resize(.UsedRange.Rows.Count, 5).ClearContents
         Set Dic = CreateObject("Scripting.Dictionary")
           For Each sh In Worksheets
            If sh.Name <> "TongHop" And sh.Name <> "DM" Then
              For Each Cls In sh.[c6].Resize(sh.UsedRange.Rows.Count)
                 If Not IsEmpty(Cls) And Not Dic.exists(Cls.Value) Then
                    Dic.Add Cls.Value, Cls.Offset(, 1) & ";" & Cls.Offset(, 2)
                      End If
                   Next
                 End If
                Next
              a = Dic.keys: b = Dic.items
            For i = 0 To Dic.Count - 1
           Set Cls = .Cells(i + 6, 3)
         Cls = a(i)
       Cls.Offset(, 1).Resize(, 2) = Split(b(i), ";")
     Next
  End With
End Sub

ndu96081631 · 21/11/10

sealand đã viết:
Mình tham gia 1 vài ý kiến:
1/ Vạn bất đắc dĩ mới dùng On error resume next, như vậy nó cũng nhảy qua lỗi không phải là trùng key. Ta sử dụng phương thức Exists mà Dictionary hỗ trợ mới hay.

Không phải đâu anh ơi! Đã có dùng Dic.Exists rồi, nhưng thêm On Error Resume Next là phòng ngừa bất trắc thôi anh à (chứ không phải vì lý do liên quan đến Key)

sealand đã viết:

2/Dictionay không gò buộc Items thì vậy sao ta không sử dụng Key như vé gửi hàng , còn Items như thùng hàng

Giải quyết như trên là thuần Dic. không phải thêm nhiếu code trung gian khác
Bạn tham khảo đoạn code mình Modify như sau:

Mã:

Sub TongHopSh()
  Dim a, b, i, Dic, It, sh As Worksheet, Cls As Range
    Application.ScreenUpdating = 0
     With Sheets("TongHop")
       .[b6].Resize(.UsedRange.Rows.Count, 5).ClearContents
         Set Dic = CreateObject("Scripting.Dictionary")
           For Each sh In Worksheets
            If sh.Name <> "TongHop" And sh.Name <> "DM" Then
              For Each Cls In sh.[c6].Resize(sh.UsedRange.Rows.Count)
                 If Not IsEmpty(Cls) And Not Dic.exists(Cls.Value) Then
                    Dic.Add Cls.Value, Cls.Offset(, 1) & ";" & Cls.Offset(, 2)
                      End If
                   Next
                 End If
                Next
              a = Dic.keys: b = Dic.items
            For i = 0 To Dic.Count - 1
           Set Cls = .Cells(i + 6, 3)
         Cls = a(i)
       Cls.Offset(, 1).Resize(, 2) = Split(b(i), ";")
     Next
  End With
End Sub

Phương pháp nối chuổi chắc chắn sẽ cho tốc độ chậm hơn so với dùng mảng ---> Điều này đã được kiểm chứng nhiều lần rồi ---> Anh có thể dùng code của anh vào file của em mà thí nghiệm xem tốc độ bao nhiêu nhé!

ptm0412 · 22/11/10

Đồng ý với ndu về chuyện transpose:
- Transpose dữ liệu trên sheet mới chậm chứ transpose mảng nhanh hơn.
- ReDim dư 1 số dòng, thí dụ ReDim 1000 dòng, dù chỉ gán giá trị cho 100 dòng thì vẫn tốn bộ nhớ cho 1000 dòng cho cả 900 dòng trống.
- Ăn gian được thì cứ ăn gian, miễn là cải thiện được tốc độ hoặc rút gọn thuật toán. Mình cũng chuyên môn ăn gian mà.

Tuy nhiên theo mình suy đoán thì anh TrungChinh chưa nghiên cứu đến biến mảng, mảng thông thường (dòng, cột) còn chưa vững nói gì đến mảng transpose (cột, dòng). Lúng túng gán giá trị không khéo là kết quả chạy bậy ngay. Do đó mình không ăn gian để anh Chính dễ mường tượng.

Hỏi thêm: Sao ndu không dùng For ... next để gán dữ liệu từ TmpArr vào Arr thay vì gán mỗi giá trị 1 dòng lệnh? Vì giả sử số cột là 80 thì phải có 80 dòng lệnh.

ndu96081631 · 22/11/10

ptm0412 đã viết:
Hỏi thêm: Sao ndu không dùng For ... next để gán dữ liệu từ TmpArr vào Arr thay vì gán mỗi giá trị 1 dòng lệnh? Vì giả sử số cột là 80 thì phải có 80 dòng lệnh.

Dạ! Đúng rà là em dùng For ngay chổ này nếu số cột nhiều hơn! Tại thấy nó chỉ có 4 cột nên viết thẳng ra luôn sư phụ à!
Mà quả thật mảng nó cũng hơi trừu tượng (em cũng đã từng đánh vật với nó, cũng đã từng hỏi sư phụ nhiều lần trước đây rồi) ---> Theo kinh nghiệm của em, để hình dung mảng 2 chiều, không gì dễ hiểu hơn là hình dung nó như 1 Range nhiều dòng nhiều cột

ptm0412 · 22/11/10

Không biết người khác thế nào chứ mình mà dùng mảng transpose (cột, dòng) phải nghĩ căng thẳng đầu óc lắm. Viết 1 dòng lệnh là 1 lần căng ra như dây đàn. Cách tư duy tựa tựa như phải nghiêng đầu qua 1 bên (nằm ngang ra ấy) để đổi cột thành dòng, dòng thành cột. Trong đầu thì tưởng tưởng ra 1 cái mảng đang quay quay, tay thì quơ quơ xoay cái mảng; miệng thì lẩm nhẩm dòng cột cột dòng, i, j, j, i.
Chắc tại già rồi.

Lê Duy Thương · 22/11/10

ptm0412 đã viết:
Không biết người khác thế nào chứ mình mà dùng mảng transpose (cột, dòng) phải nghĩ căng thẳng đầu óc lắm. Viết 1 dòng lệnh là 1 lần căng ra như dây đàn. Cách tư duy tựa tựa như phải nghiêng đầu qua 1 bên (nằm ngang ra ấy) để đổi cột thành dòng, dòng thành cột. Trong đầu thì tưởng tưởng ra 1 cái mảng đang quay quay, tay thì quơ quơ xoay cái mảng; miệng thì lẩm nhẩm dòng cột cột dòng, i, j, j, i.
Chắc tại già rồi.

nếu dùng vòng lặp có phải dùng thêm như thế này không sư phụ và bác NDU
Arr(1, i) = Cls.Offset(, 0).Value
Arr(2, i) = Cls.Offset(, 1).Value
Arr(3, i) = Cls.Offset(, 2).Value
Arr(4, i) = Cls.Offset(, 3).Value
thay bằng

For j = 1 To 4
ReDim Preserve Arr(1 To 4, 1 To i)
Arr(j, i) = Cls.Offset(, j - 1).Value
Next

ndu96081631 · 22/11/10

Le duy Thuong đã viết:
nếu dùng vòng lặp có phải dùng thêm như thế này không sư phụ và bác NDU
Arr(1, i) = Cls.Offset(, 0).Value
Arr(2, i) = Cls.Offset(, 1).Value
Arr(3, i) = Cls.Offset(, 2).Value
Arr(4, i) = Cls.Offset(, 3).Value
thay bằng

For j = 1 To 4
ReDim Preserve Arr(1 To 4, 1 To i)
Arr(j, i) = Cls.Offset(, j - 1).Value
Next

Đoạn ReDim Preserve Arr(1 To 4, 1 To i) cho nằm ở trên bạn à! Tức

PHP:

ReDim Preserve Arr(1 To 4, 1 To i)
For j = 1 To 4
  Arr(j, i) = Cls.Offset(, j - 1).Value
Next

Lê Duy Thương · 22/11/10

ndu96081631 đã viết:
Đoạn ReDim Preserve Arr(1 To 4, 1 To i) cho nằm ở trên bạn à! Tức

PHP:

ReDim Preserve Arr(1 To 4, 1 To i) For j = 1 To 4 Arr(j, i) = Cls.Offset(, j - 1).Value Next

PHP:

Sub TONGHOP()
  Dim Dic, Sh As Worksheet, Cls As Range, i As Long, Arr()
  On Error Resume Next
  Sheets("TongHop").Range("C6:F60000").ClearContents
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each Sh In Worksheets
    If Sh.Name <> "TongHop" And Sh.Name <> "DM" Then
      For Each Cls In Sh.Range(Sh.[C6], Sh.[C65536].End(xlUp))
        If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then
          Dic.Add Cls.Value, ""
          i = i + 1
          ReDim Preserve Arr(1 To 4, 1 To i)
          For j = 1 To 4
          Arr(j, i) = Cls.Offset(, j - 1).Value
         Next
        End If
      Next
    End If
  Next
  Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
End Sub

CÁC ĐOẠN CODE TRÊN ĐỀU DÙNG ĐỂ LỌC RA DUY NHẤT NHƯ MÃ SỐ VÀ TÊN
CÒN BÂY GIỜ NẾU CÓ 1 MÃ SỐ NẰM CHUNG 3 SHEET THÌ SỐ LƯỢNG SUM NHƯ THẾ NÀO SƯ PHỤ VÀ BÁC NDU
VÍ DỤ MÃ SỐ 1001 BANG1 SL=1000,BẢNG 2 SL=1000, BẢNG 3 SL=1000 KÊT QUẢ =3000
BÂY GIỜ THÌ SỦA CODE NHƯ THẾ NÀO Ạ
THÔNG THƯỜNG THÌ EM DUNG COPY VALUE SAU ĐÓ SUMIF VÀ VALUE GIÁ TRỊ
CUỐI CÙNG REMOVE DUPLICATE VALUE LÀ XONG
NHƯNG TRÊN DICTIONARY THÌ THUA

ndu96081631 · 22/11/10

Le duy Thuong đã viết:
PHP:

Sub TONGHOP() Dim Dic, Sh As Worksheet, Cls As Range, i As Long, Arr() On Error Resume Next Sheets("TongHop").Range("C6:F60000").ClearContents Set Dic = CreateObject("Scripting.Dictionary") For Each Sh In Worksheets If Sh.Name <> "TongHop" And Sh.Name <> "DM" Then For Each Cls In Sh.Range(Sh.[C6], Sh.[C65536].End(xlUp)) If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then Dic.Add Cls.Value, "" i = i + 1 ReDim Preserve Arr(1 To 4, 1 To i) For j = 1 To 4 Arr(j, i) = Cls.Offset(, j - 1).Value Next End If Next End If Next Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr) End Sub

CÁC ĐOẠN CODE TRÊN ĐỀU DÙNG ĐỂ LỌC RA DUY NHẤT NHƯ MÃ SỐ VÀ TÊN
CÒN BÂY GIỜ NẾU CÓ 1 MÃ SỐ NẰM CHUNG 3 SHEET THÌ SỐ LƯỢNG SUM NHƯ THẾ NÀO SƯ PHỤ VÀ BÁC NDU
VÍ DỤ MÃ SỐ 1001 BANG1 SL=1000,BẢNG 2 SL=1000, BẢNG 3 SL=1000 KÊT QUẢ =3000
BÂY GIỜ THÌ SỦA CODE NHƯ THẾ NÀO Ạ
THÔNG THƯỜNG THÌ EM DUNG COPY VALUE SAU ĐÓ SUMIF VÀ VALUE GIÁ TRỊ
CUỐI CÙNG REMOVE DUPLICATE VALUE LÀ XONG
NHƯNG TRÊN DICTIONARY THÌ THUA

Chú ý: Tại vị trí i nào đó thỏa mản sự không tồn tại của Dictionary thì ta sẽ Add đồng thời cộng dồn
Chẳng hạn Arr(2, i) = Arr(2, i) + Cls.Offset(, 1).Value
Nghiên cứu trước đi, nếu không được thì... tiếp

ptm0412 · 22/11/10

Cộng dồn thì ở đây: Lấy DM duy nhất theo nhiều cột (bài #11). Yên tâm 1 điều là rất rất trừu tượng. khà khà khà.

Hình như ndu nhầm: thoả mãn thì add item mà không cộng mới đúng. Không thoả mãn mới tìm và cộng.

Đại khái là nếu Dic chưa có, thì add vào.
Nếu Dic có rồi, thì tìm xem nằm dòng nào trong Dic, lấy dòng tương ứng của Arr kết quả (cột cần cộng) cộng với số liệu mới của Arr sheet. Không add item vào, add vào thì còn gì là duy nhất.

ptm0412 · 22/11/10

PHP:

Option Base 1
____________________________

Sub TongHopSh()

    Dim sh, Dic, iRow, cls, RowsCount
    Dim ArrSh(), ArrKetqua(1000, 4)
    With Sheets("TongHop")
       .[b6].Resize(.UsedRange.Rows.Count, 4).ClearContents

       Set Dic = CreateObject("Scripting.Dictionary")
       For Each sh In Worksheets
            If sh.Name <> "TongHop" And sh.Name <> "DM" Then
                RowsCount = sh.[c65000].End(xlUp).Row - 5
                ReDim ArrSh(RowsCount, 4)
                ArrSh = sh.[c6].Resize(RowsCount, 4).Value
                For i = 1 To RowsCount
                   If Not Dic.exists(ArrSh(i, 1)) Then
                        Dic.Add ArrSh(i, 1), ""
                        iRow = iRow + 1
                        For j = 1 To 4
                            ArrKetqua(iRow, j) = ArrSh(i, j)
                        Next
                   'Thêm Else chỗ này'
                   Else
                       nRow = Application.Match(ArrSh(i, 1), Dic.Keys, 0)
                       ArrKetqua(nRow, 3) = ArrKetqua(nRow, 3) + ArrSh(i, 3)
                    End If
                Next
            End If
      Next
        .[c6].Resize(Dic.Count, 4) = ArrKetqua
    
    End With
End Sub

ndu96081631 · 22/11/10

ptm0412 đã viết:
Cộng dồn thì ở đây: Lấy DM duy nhất theo nhiều cột (bài #11). Yên tâm 1 điều là rất rất trừu tượng. khà khà khà.

Hình như ndu nhầm: thoả mãn thì add item mà không cộng mới đúng. Không thoả mãn mới tìm và cộng.

Đại khái là nếu Dic chưa có, thì add vào.
Nếu Dic có rồi, thì tìm xem nằm dòng nào trong Dic, lấy dòng tương ứng của Arr kết quả (cột cần cộng) cộng với số liệu mới của Arr sheet. Không add item vào, add vào thì còn gì là duy nhất.

Uh... vội quá nên em nhầm (dù rằng bài loại này làm đến.. nhàm luôn rồi)
Em không dùng hàm MATCH mà đánh dấu vào trong Item của Dictionary --> Cách này luôn cho tốc độ nhanh hơn gấp vài chục lần so với MATCH

PHP:

Sub TongHopSh()
  Dim Dic, sh As Worksheet, iRow As Long, i As Long, j As Long
  Dim Arr(), TmpArr, TG As Double
  On Error Resume Next
  TG = Timer
  Application.ScreenUpdating = False
  Sheets("TongHop").Range("C6:F60000").ClearContents
  With CreateObject("Scripting.Dictionary")
    For Each sh In Worksheets
      If sh.Name <> "TongHop" And sh.Name <> "DM" Then
        TmpArr = sh.Range(sh.[c6], sh.[C65536].End(xlUp)).Resize(, 4).Value
        For iRow = 1 To UBound(TmpArr, 1)
          If Not IsEmpty(TmpArr(iRow, 1)) Then
            If Not .Exists(TmpArr(iRow, 1)) Then
              i = i + 1
              .Add TmpArr(iRow, 1), i  '<--- Đây là chổ ta đánh dấu vị trí
              ReDim Preserve Arr(1 To 4, 1 To i)
              For j = 1 To 4
                Arr(j, i) = TmpArr(iRow, j)
              Next
            Else
              Arr(3, .Item(TmpArr(iRow, 1))) = Arr(3, .Item(TmpArr(iRow, 1))) + TmpArr(iRow, 3)
            End If
          End If
        Next
      End If
    Next
  End With
  Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
  Application.ScreenUpdating = True
  MsgBox Timer - TG
End Sub

1.2s là tốc độ của code khi chạy 60000 dòng mổi sheet

Nhờ hướng dẫn sử dụng Dictionary Object. (1 người xem)

Người dùng đang xem chủ đề này

Thành viên tích cực

Bad Excel Member

Thành viên tích cực

File đính kèm

Huyền thoại GPE

Bad Excel Member

Thành viên tích cực

Bad Excel Member

Huyền thoại GPE

File đính kèm

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

File đính kèm

Huyền thoại GPE

Bad Excel Member

Huyền thoại GPE

Bad Excel Member

Cạo lấy gì gội (Dịch quá không gội được)

Huyền thoại GPE

Cạo lấy gì gội (Dịch quá không gội được)

Huyền thoại GPE

Bad Excel Member

Bad Excel Member

Huyền thoại GPE

File đính kèm

Đếm ngược thời gian