Copy code có chiều dài 12 (1 người xem)

[nmhung49]

Em muốn copy những ô có chiều dài bằng 12 sang cột B mà em đã dùng vòng lặp như chỉ copy được ô cuối cùng của cột A mong các anh chị giúp đỡ để sao những ô có chiều dài bằng 12 đều được copy sang cột B Em đã viết thử code trong 2 module với module 1 là module mà sử dụng như không được Còn module 2 em đã đi đường vòng để đạt được mong các anh chị & các bạn giúp đỡ chỉ sử code trong module 1 không qua filter. Thanks

 

[ndu96081631]

Em muốn copy những ô có chiều dài bằng 12 sang cột B mà em đã dùng vòng lặp như chỉ copy được ô cuối cùng của cột A mong các anh chị giúp đỡ để sao những ô có chiều dài bằng 12 đều được copy sang cột B Em đã viết thử code trong 2 module với module 1 là module mà sử dụng như không được Còn module 2 em đã đi đường vòng để đạt được mong các anh chị & các bạn giúp đỡ chỉ sử code trong module 1 không qua filter. Thanks

Cái này cần quái gì đến vòng lập
Bạn đã biết dùng AutoFilter sao không biết Custom điều kiện = "????????????"

Sub copycode1()
  With Range([A1], [A65536].End(xlUp))
    .AutoFilter 1, "????????????"
    .SpecialCells(12).Copy [b1]
    .AutoFilter
  End With
End Sub

hoặc:

Sub copycode1()
  With Range([A1], [A65536].End(xlUp))
    .AutoFilter 1, String(12, "?")
    .SpecialCells(12).Copy Range("B1")
    .AutoFilter
  End With
End Sub

Chú ý: Chèn 1 dòng làm tiêu đề ---> Dữ liệu sẽ bắt đầu từ dòng 2

 

[ndu96081631]

Thêm 1 code dùng Array

Gữi bạn thêm 1 code khác tham khảo

Sub copycode1()
  Dim SrcArray, Item, Tmp(1 To 60000, 1 To 1), i As Long
  SrcArray = Range([A1], [A65536].End(xlUp)).Value
  For Each Item In SrcArray
    If Len(Item) = 12 Then
      i = i + 1
      Tmp(i, 1) = Item
    End If
  Next
  Range("B1").Resize(i).Value = Tmp
End Sub

Code này dùng Array, cho tốc độ thuộc hàng "khủng" nhất ---> Với 60.000 dòng dữ liệu, nó ra kết quả trong thời gian 0.1 giây
Ẹc.. Ẹc...
(Với dữ liệu cực lớn có khi AutoFilter không dùng được)

 

[nmhung49]

Cho em hỏi anh khai báo biến dim Tmp(1 To 60000, 1 To 1)đoạn này có nghĩa là gì vậy ndu với lại mình không có Next item mà không bị báo lỗi? Thanks

 

[ndu96081631]

Cho em hỏi anh khai báo biến dim Tmp(1 To 60000, 1 To 1)đoạn này có nghĩa là gì vậy

Khai báo 1 mảng dọc có 60000 phần tử thôi mà (khai báo dư thế cho chắc)

với lại mình không có Next item mà không bị báo lỗi?

Ở trên là For Each Item..., ở dưới chỉ cần Next thôi thì nó cũng ngầm hiểu là Next Item rồi còn gì
-----------------------------
Sẳn đây đố bạn biết code trên có khả năng gây lỗi trong trường hợp nào?
Nghiên cứu xem!

 

[nmhung49]

Sẳn đây đố bạn biết code trên có khả năng gây lỗi trong trường hợp nào?
Nghiên cứu xem!

Báo lỗi khi tổng những ô chứa dữ liệu có chiều dài 12 vượt quá 60.000không biết đúng không Ndu Khi đó biến tmp bị lỗi

 

[ndu96081631]

Báo lỗi khi tổng những ô chứa dữ liệu có chiều dài 12 vượt quá 60.000không biết đúng không Ndu Khi đó biến tmp bị lỗi

Cái lỗi này chẳng quan trọng, vì ta có thể khởi tạo tmp(1 to 65536, 1 to 1) cơ mà
Chú ý 2 trường hợp:
- Cột A chẳng có dữ liệu nào
- Tìm trong cột A nhưng chẳng có cell nào thỏa điều kiện chiều dài = 12

 

[le tin]

Sub copycode1()
Dim SrcArray, Item, Tmp(1 To 60000, 1 To 1), i As Long
SrcArray = Range([A1], [A65536].End(xlUp)).Value
For Each Item In SrcArray
If Len(Item) = 12 Then
i = i + 1
Tmp(i, 1) = Item
End If
Next
Range("B1").Resize(i).Value = Tmp
End Sub

Chào bạn Ndu , nếu mình muốn áp dụng để lọc 3 điều kiện (3 cột) thì sửa lại thế nào . Cảm ơn

 

[ndu96081631]

Chào bạn Ndu , nếu mình muốn áp dụng để lọc 3 điều kiện (3 cột) thì sửa lại thế nào . Cảm ơn

Bạn cho ví dụ cụ thể đi, tùy theo điều kiện lọc mới biết viết code thế nào chứ (chắc phải AND...)
(Cho file lên càng tốt)

 

[le tin]

Mình đã gởi file , bạn xem giúp nha

 

[ndu96081631]

Mình đã gởi file , bạn xem giúp nha

Thì AutoFilter 3 lần như bạn làm bằng tay thôi

Sub copycode1()
  With Range([A1], [A65536].End(xlUp)).Resize(, 3)
    .AutoFilter 1, "????????????"
    .AutoFilter 2, "a"
    .AutoFilter 3, 5
    .Resize(, 1).SpecialCells(12).Copy Range("D1")
    .AutoFilter
  End With
End Sub

Có điều như tôi đã nói ở trên, với dữ liệu lớn thì AutoFilter sẽ không làm việc được, hay nói chính xác hơn thì SpecialCells sẽ bị lỗi ---> Vậy nên dùng Array tuy có phức tạp hơn nhưng dữ liệu bao nhiêu cũng chơi tuốt mà tốc độ xử lý lại cực cao!

 

[MinhCong]

Thì AutoFilter 3 lần như bạn làm bằng tay thôi

Sub copycode1()
  With Range([A1], [A65536].End(xlUp)).Resize(, 3)
    .AutoFilter 1, "????????????"
    .AutoFilter 2, "a"
    .AutoFilter 3, 5
    .Resize(, 1).SpecialCells(12).Copy Range("D1")
    .AutoFilter
  End With
End Sub

Có điều như tôi đã nói ở trên, với dữ liệu lớn thì AutoFilter sẽ không làm việc được, hay nói chính xác hơn thì SpecialCells sẽ bị lỗi ---> Vậy nên dùng Array tuy có phức tạp hơn nhưng dữ liệu bao nhiêu cũng chơi tuốt mà tốc độ xử lý lại cực cao!

Anh có thể cho đoạn code dùng Array để Anh Em học hỏi được không?

 

[ndu96081631]

Anh có thể cho đoạn code dùng Array để Anh Em học hỏi được không?

Thì vầy thôi:

Sub copycode2()
  Dim Src1, Src2, Src3, Arr(1 To 60000, 1 To 1), i As Long, j As Long
  With Range([A1], [A65536].End(xlUp))
    Src1 = .Offset(, 0).Value
    Src2 = .Offset(, 1).Value
    Src3 = .Offset(, 2).Value
  End With
  For i = 1 To UBound(Src1)
    If Len(Src1(i, 1)) = 12 And Src2(i, 1) = "a" And Src3(i, 1) = 5 Then
      j = j + 1
      Arr(j, 1) = Src1(i, 1)
    End If
  Next
  Range("D1").Resize(j).Value = Arr
End Sub

Code này chưa bẩy lỗi, các bạn tự nghiên cứu nhé

 

[ThuNghi]

Thì vầy thôi:

Sub copycode2()
  Dim Src1, Src2, Src3, Arr(1 To 60000, 1 To 1), i As Long, j As Long
  With Range([A1], [A65536].End(xlUp))
    Src1 = .Offset(, 0).Value
    Src2 = .Offset(, 1).Value
    Src3 = .Offset(, 2).Value
  End With
  For i = 1 To UBound(Src1)
    If Len(Src1(i, 1)) = 12 And Src2(i, 1) = "a" And Src3(i, 1) = 5 Then
      j = j + 1
      Arr(j, 1) = Src1(i, 1)
    End If
  Next
  Range("D1").Resize(j).Value = Arr
End Sub

Code này chưa bẩy lỗi, các bạn tự nghiên cứu nhé

Code này nhanh hơn 1 chút nè.
Chưa bẫy lỗi.

Sub copycode2()
  'NhanBan
  Dim Src1, Arr(1 To 65000, 1 To 3), i As Long, j As Long
  Dim T
  T = Timer
  Columns("D").ClearContents
  Src1 = Range("A2:C" & Cells(65000, 1).End(xlUp).Row)
  For i = 1 To UBound(Src1)
    If Len(Src1(i, 1)) = 12 Then
      If Src1(i, 2) = "a" Then
        If Src1(i, 3) = 5 Then
          j = j + 1
          Arr(j, 1) = Src1(i, 1)
        End If
      End If
    End If
  Next
  Range("D1").Resize(j).Value = Arr
  Range("A200:C65000").ClearContents
  [G2] = Timer - T
End Sub

 

[le tin]

Bạn NDU xem lại có sót gì mà không chạy được

Sub copycode1()
  With Range([A1], [A65536].End(xlUp)).Resize(, 3)
    .AutoFilter 1, "????????????"
    .AutoFilter 2, "a"
    .AutoFilter 3, 5
    .Resize(, 1).SpecialCells(12).Copy Range("D1")
    .AutoFilter
  End With
End Sub

Bạn ThuNghi hình như dư cái này

Range("A200:C65000").ClearContents

Tôi sửa lại để copy 3 cột
Arr(j, 1) = Src1(i, 1)
Arr(j, 2) = Src1(i, 2)
Arr(j, 3) = Src1(i, 3)
Vậy rút gọn còn 1 dòng thì làm thế nào bạn

 

[ThuNghi]

Bạn ThuNghi hình như dư cái này
Tôi sửa lại để copy 3 cột
Arr(j, 1) = Src1(i, 1)
Arr(j, 2) = Src1(i, 2)
Arr(j, 3) = Src1(i, 3)
Vậy rút gọn còn 1 dòng thì làm thế nào bạn

Xin lỗi Anh, em thêm cái dòng đó để tính gởi file lên cho nhẹ, cần thì nhân bản 200 dòng có sẵn, anh bỏ đi.
Hiện tại em chưa biết cách gán vào cùng lúc nhiều dòng.
Vậy ngoài cách như anh chắc dùng thêm 1 for nữa quá

For k=1 to 3
Arr(j, k) = Src1(i, k)
next k

Khi nào tìm ra cách khác, em sẽ up lên.

 

[ndu96081631]

Bạn NDU xem lại có sót gì mà không chạy được

Tôi thử rồi mới đưa lên đấy đồng chí à!

Tôi sửa lại để copy 3 cột
Arr(j, 1) = Src1(i, 1)
Arr(j, 2) = Src1(i, 2)
Arr(j, 3) = Src1(i, 3)
Vậy rút gọn còn 1 dòng thì làm thế nào bạn

Cái đó không rút gọn đựoc, muốn copy ra thành 3 cột thì sửa:
Range("D1").Resize(j).Value = Arr
thành:
Range("D1").Resize(j,3).Value = Arr

 

[le tin]

Tôi thử rồi mới đưa lên đấy đồng chí à!

Vâng tôi thử lại được rồi
Riêng chỗ rút gọn , nếu tôi không dùng for... thì đoạn code giữa có bao nhiêu cột thì bấy nhiêu dòng . Ý tôi là liệu có cách gì khác không

 

[ndu96081631]

Vâng tôi thử lại được rồi
Riêng chỗ rút gọn , nếu tôi không dùng for... thì đoạn code giữa có bao nhiêu cột thì bấy nhiêu dòng . Ý tôi là liệu có cách gì khác không

Khoảng 5 cột trở lại, ta chịu khó viết 5 dòng cũng chẳng hề gì
Nếu số cột nhiều hơn thế, dùng thêm 1 vòng lập For nữa, đâu khó khăn gì...
Ví dụ:

Sub copycode2()
  Dim Src, Arr(1 To 60000, 1 To 3), i As Long, j As Long
  Src = Range([A1], [A65536].End(xlUp)).Resize(, 3).Value
  For i = 1 To UBound(Src)
    If Len(Src(i, 1)) = 12 And Src(i, 2) = "a" And Src(i, 3) = 5 Then
      j = j + 1
      For k = 1 To 3 '<--- so cot
        Arr(j, k) = Src(i, k)
      Next
    End If
  Next
  Range("D1").Resize(j, k).Value = Arr
End Sub

Code trên copy ra 3 cột
(chú ý Format Text cho vùng trích dữ liệu)

 

[sealand]

Mình muốn tham gia thêm một chút. Dùng Advance Filter cũng được mà, trong khi nó là chức năng cố hữu của Exc nên chắc chắn tốc độ sẽ tốt hơn. Chỉ có điểu lỉnh kỉnh 1 chút là phải mượn tạm 1 vùng làm tiêu chuẩn thôi. Các bạn tham khảo xem

Option Explicit
Sub Macro1()
Dim Rg As Range
Application.ScreenUpdating = False
With Sheet1
.[a1:c1].Copy .[i1]
.[i2] = "????????????": .[j2] = "a": .[k2] = 5
Set Rg = .Range("A1:C" & .[a56536].End(xlUp).Row)
Rg.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.[i1:k2]
    .Columns("A:A").Copy .[d1]
   ActiveSheet.ShowAllData
   .[i1:k2].Clear
   .[d1].Delete Shift:=xlUp
   End With
   Application.ScreenUpdating = True
End Sub

 

[concogia]

Chào bạn Ndu , nếu mình muốn áp dụng để lọc 3 điều kiện (3 cột) thì sửa lại thế nào . Cảm ơn

Mình chỉ thắc mắc sao không chỉnh lại code của Thầy Ndu một tý là được mà, hay có gì không ổn mà mình chưa biết

Sub copycode3()
    Dim SrcArray, Item, Tmp(1 To 60000, 1 To 1), i As Long
      Set SrcArray = Range([A1], [A65536].End(xlUp))
        For Each Item In SrcArray
          If Len(Item) = 12 And Item.Offset(0, 1) = "a" And Item.Offset(0, 2) = 5 Then
            i = i + 1
            Tmp(i, 1) = Item
          End If
        Next
Range("d1").Resize(i).Value = Tmp
End Sub

 

[sealand]

Điều không ổn lại chính từ phong cách sử lý Ndu, lâu dần thành "nhiễm" (Cám ơn Ndu nha). Luôn phải đặt tiêu chí cho Giải pháp: Đơn Giản-Hiệu Quả
Khi đã ổn thì chính là lúc phải xem lại có gì còn kém ổn. Về lý thuyết Code của Ndu là quá ổn, nhưng thực tế lại hạn chế về tốc độ khi dữ liệu sử lý lớn. Chính Ndu là người tìm cách hạn chế lạm dụng vòng lặp đó thôi. Ngay các phần mềm người ta cũng tìm cách sử dụng SQL để tổng hợp thay vì duyệt lần lượt, kể cả lượt trên các Table chỉ số.
Y kiến của mình xuất phát chỉ vậy thôi.

 

[ndu96081631]

Mình muốn tham gia thêm một chút. Dùng Advance Filter cũng được mà, trong khi nó là chức năng cố hữu của Exc nên chắc chắn tốc độ sẽ tốt hơn. Chỉ có điểu lỉnh kỉnh 1 chút là phải mượn tạm 1 vùng làm tiêu chuẩn thôi. Các bạn tham khảo xem

Option Explicit
Sub Macro1()
Dim Rg As Range
Application.ScreenUpdating = False
With Sheet1
.[a1:c1].Copy .[i1]
.[i2] = "????????????": .[j2] = "a": .[k2] = 5
Set Rg = .Range("A1:C" & .[a56536].End(xlUp).Row)
Rg.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.[i1:k2]
    .Columns("A:A").Copy .[d1]
   ActiveSheet.ShowAllData
   .[i1:k2].Clear
   .[d1].Delete Shift:=xlUp
   End With
   Application.ScreenUpdating = True
End Sub

Không chắc có thể dùng Advanced Filter trong mọi trường hợp đâu anh à!
Anh xem file ví dụ của em đây, dữ liệu 60.000 dòng ---> Advanced Filter báo lỗi (nếu anh xóa bớt dữ liệu, chưa lại chừng 20.000 dòng thì code chạy được)
Cho đến thời điểm này, theo sự hiểu biết của em thì không có code nào có thể sánh được về mặt tốc độ so với cách dùng Array đâu (kể cả những công cụ có sẳn)
Em dùng Array, với dữ liệu 60.000 dòng, ra kết quả trong vòng 0.2 s
--------------------------
Anh hãy tham khảo bài toán kinh điển về lọc dữ liệu tại đây: So sánh trùng và không trùng trên 2 cột (Post bởi viendo)
Code có tốc độ cao nhất cũng phải mất ít nhất 10s cho dữ liệu 15.000 dòng ---> Em dùng Array, mất chỉ 0.5s

 

[le tin]

Bạn Ndu cho mình hỏi : phải thêm đoạn code lọc duy nhất và lấy tổng ở cột C cho vào cột E thì thế nào
Cảm ơn

 

[sealand]

Không chắc có thể dùng Advanced Filter trong mọi trường hợp đâu anh à!
Anh xem file ví dụ của em đây, dữ liệu 60.000 dòng ---> Advanced Filter báo lỗi (nếu anh xóa bớt dữ liệu, chưa lại chừng 20.000 dòng thì code chạy được)
Cho đến thời điểm này, theo sự hiểu biết của em thì không có code nào có thể sánh được về mặt tốc độ so với cách dùng Array đâu (kể cả những công cụ có sẳn)
Em dùng Array, với dữ liệu 60.000 dòng, ra kết quả trong vòng 0.2 s

Cái sai ở đây không phải sai ở Advance filter mà là sai ở việc xác định dòng cuối của vùng dữ liệu. Mình chưa kịp kiểm tra là tại sao trong trường hợp này lệnh sau lại trả về giá trị là 1

Sheet1.[a56536].End(xlUp).Row

Vậy ta cứ tạm thay

Set Rg = .Range("A1:C" & .[a56536].End(xlUp).Row)

Bằng:

Set Rg = .Range("A1:C65028")

Như vậy thời gian chạy Code của mình thường nhỏ hơn của Ndu (Mỗi code test 10 lần: Nhỏ nhất của Seland là 0.125625 của Ndu là 0.187625)

P/S: Mình tìm ra lỗi rồi (Mình gõ lộn số .[a65536].End(xlUp).Row thành .[a56536].End(xlUp).Row

 

[ndu96081631]

Bạn Ndu cho mình hỏi : phải thêm đoạn code lọc duy nhất và lấy tổng ở cột C cho vào cột E thì thế nào
Cảm ơn

Hỏi lại: Đây là 1 bài toán riêng hay kết hợp với bài toán lọc 12 ký tự ở trên?
Sao bạn không cho file lên nhỉ? Mấy bài toán thuộc dạng phức tạp, nếu chỉ mô tả bằng lời thì khó mà làm được lắm bạn à!

 

[ThuNghi]

Bạn Ndu cho mình hỏi : phải thêm đoạn code lọc duy nhất và lấy tổng ở cột C cho vào cột E thì thế nào
Cảm ơn

Nếu lọc duy nhất, theo em biết thì dùng arr chậm hơn nhiều so với AdFi.
Hình như vấn đề này cũng có tham khảo trên GPE lâu rồi nên em không nhớ link.
Chỉ còn ví dụ, em làm thử = AdFi với > 60.000 dòng thì OK. Có khi code dùng arr kia chưa tối ưu.
Em lúc này đang rất muốn nghiên cứu về Arr.

 

[ndu96081631]

Cái sai ở đây không phải sai ở Advance filter mà là sai ở việc xác định dòng cuối của vùng dữ liệu. Mình chưa kịp kiểm tra là tại sao trong trường hợp này lệnh sau lại trả về giá trị là 1

Sheet1.[a56536].End(xlUp).Row

Vậy ta cứ tạm thay

Set Rg = .Range("A1:C" & .[a56536].End(xlUp).Row)

Bằng:

Set Rg = .Range("A1:C65028")

Như vậy thời gian chạy Code của mình thường nhỏ hơn của Ndu

Vấn đề không phải nằm ở chổ đó anh à!
Ý em muốn nói đoạn này:
.Columns(A:A).Copy .[D1]
Sẽ hoàn toàn tương đương với
.Columns(A:A).SpecialCells(12).Copy .[D1]
Đúng không? (Khi anh Ctrl + C, nó chỉ copy những cell Visible mà thôi)
Và trong 1 số trường hợp nào đó, khi số lượng Areas vượt quá mức cho phép thì anh sẽ không bao giờ copy được ---> Với code của anh, nó sẽ copy toàn bộ ra cột D, tức nguồn thế nào thì đích sẽ y chang thế... Còn nếu anh thêm SpecialCells vào thì code sẽ báo lỗi ---> Trường hợp này, Advanced Filter bị tan rã hoàn toàn (không dùng được thì lấy đâu ra thời gian để so sánh?)
Anh hãy kiểm tra với file mới này sẽ biết liền!

 

[sealand]

Mình không hiểu khi nào có thể rã được SpecialCells chứ mình thử cho gần hết dữ liệu mẫu của Ndu thoả mãn nó vẫn bình thường mà.

 

[le tin]

Hỏi lại: Đây là 1 bài toán riêng hay kết hợp với bài toán lọc 12 ký tự ở trên?
Sao bạn không cho file lên nhỉ? Mấy bài toán thuộc dạng phức tạp, nếu chỉ mô tả bằng lời thì khó mà làm được lắm bạn à!

Gởi file cho bạn , đã giảm bớt dòng

 

[le tin]

Nếu lọc duy nhất, theo em biết thì dùng arr chậm hơn nhiều so với AdFi.
Hình như vấn đề này cũng có tham khảo trên GPE lâu rồi nên em không nhớ link.
Chỉ còn ví dụ, em làm thử = AdFi với > 60.000 dòng thì OK. Có khi code dùng arr kia chưa tối ưu.
Em lúc này đang rất muốn nghiên cứu về Arr.

Thông thường mình vẫn làm vậy , nhưng sau đó kết hợp thêm Sumif hoặc Sumproduct và đến 20.000 dòng thì ...
Giải pháp thì đã có , vấn đề là tốc độ

 

[ndu96081631]

Gởi file cho bạn , đã giảm bớt dòng

Tính trứoc cho bạn dữ liệu 65536 dòng luôn

Sub NDU()
  Dim Src, Arr(1 To 65535, 1 To 2)
  Dim Tmp, i As Long, j As Long, TG As Double
  TG = Timer
  With Range("A2:C65536")
    Src = .Value
    .Resize(, 1).Offset(, 3).NumberFormat = "@"
  End With
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Src)
      If Len(Src(i, 1)) = 12 Then
        If Src(i, 2) = "a" Then
          If Src(i, 3) > 4 Then
            Tmp = Src(i, 1)
            If Not .Exists(Tmp) Then
              j = j + 1
              .Add Tmp, j
              Arr(j, 1) = Tmp
              Arr(j, 2) = Src(i, 3)
            Else
              Arr(.Item(Tmp), 2) = Val(Arr(.Item(Tmp), 2)) + Val(Src(i, 3))
            End If
          End If
        End If
      End If
    Next
  End With
  Range("D2").Resize(j, 2).Value = Arr
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Thí nghiệm và cảm nhận tốc độ nha
Ai thử dùng Advanced Filter hay bất cứ cách gì xem tốc độ có hơn đựoc code này không?

 

[ThuNghi]

Tính trứoc cho bạn dữ liệu 65536 dòng luôn

Sub NDU()
  Dim Src, Arr(1 To 65535, 1 To 2)
  Dim Tmp, i As Long, j As Long, TG As Double
  TG = Timer
  With Range("A2:C65536")
    Src = .Value
    .Resize(, 1).Offset(, 3).NumberFormat = "@"
  End With
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Src)
      If Len(Src(i, 1)) = 12 Then
        If Src(i, 2) = "a" Then
          If Src(i, 3) > 4 Then
            Tmp = Src(i, 1)
            If Not .Exists(Tmp) Then
              j = j + 1
              .Add Tmp, j
              Arr(j, 1) = Tmp
              Arr(j, 2) = Src(i, 3)
            Else
              Arr(.Item(Tmp), 2) = Val(Arr(.Item(Tmp), 2)) + Val(Src(i, 3))
            End If
          End If
        End If
      End If
    Next
  End With
  Range("D2").Resize(j, 2).Value = Arr
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Thí nghiệm và cảm nhận tốc độ nha
Ai thử dùng Advanced Filter hay bất cứ cách gì xem tốc độ có hơn đựoc code này không?

Rất hay, học thêm nhiều chiêu mới, hay và nhanh nữa, mình sẽ ứng dụng thay thế dần AdFi.

CreateObject("Scripting.Dictionary")
...
If Not .Exists(Tmp)

Cám ơn NDU rất nhiều.

 

[ThuNghi]

Tôi mới học của NDU về CreateObject("Scripting.Dictionary") và làm thử 1 code về so sánh trích lọc giữa AdFi và Array.
NDU xem và chỉnh giúp, sao tôi thấy vẫn chậm hơn AdFi.

Option Explicit
Dim ListSort As Range
Sub UniqueArray()
Dim endR As Long 'Copy NDU
Dim Src As Variant, Arr  As Variant
Dim Tmp, i As Long, j As Long, TG As Double
TG = Timer
With Sheets("Data")
  endR = .Cells(65000, 1).End(xlUp).Row
  ReDim Arr(1 To endR, 1 To 2)
  With Range("A2:A" & endR)
    Src = .Value
  End With
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Src)
      Tmp = Src(i, 1)
        If Not .Exists(Tmp) Then
          j = j + 1
          .Add Tmp, j
          Arr(j, 1) = Tmp
        End If
      Next
  End With
End With
If j = 0 Then Exit Sub
Range("D2").Resize(j).Value = Arr
Set ListSort = Range("D2", Range("D65000").End(xlUp))
With ListSort
    .Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
Set ListSort = Nothing
MsgBox Format(Timer - TG, "0.000000000")
End Sub

Và dùng AdFi

Option Explicit
Dim rngMyRange As Range, ListSort As Range
Dim MyArray()
Dim i As Long, j As Long, X As Long, y As Long
Dim TG As Double
Sub SortAF()
Dim TG As Double
TG = Timer
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
Set rngMyRange = Range("A1", Range("A65000").End(xlUp))
Range("E1:E10000").ClearContents
With rngMyRange
    .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
        "E1"), Unique:=True
End With
Set ListSort = Range("E2", Range("E65000").End(xlUp))
With ListSort
    .Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
Set ListSort = Nothing
Set rngMyRange = Nothing
With Application
    .Names("extract").Delete
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
MsgBox Format(Timer - TG, "0.000000000")
End Sub

Đính kèm theo file với hơn 60.000 dòng.
Cám ơn rất nhiều.

 

[ndu96081631]

Tôi mới học của NDU về CreateObject("Scripting.Dictionary") và làm thử 1 code về so sánh trích lọc giữa AdFi và Array.
NDU xem và chỉnh giúp, sao tôi thấy vẫn chậm hơn AdFi.
.

Nếu chỉ có Filter Unique thôi thì AF nhanh hơn Array cũng là chuyện bình thường ---> Nếu lọc và thêm vài điều kiện nữa xem ---> Bảo đảm AF chết liền
Giống bài 32 đấy thôi, vừa Unique vừa cộng dồn, AF làm sao chịu nỗi
----------------
Code dùng Array tôi sửa lại cho gọn chút:

Sub UniqueArray()
  Dim Src, Arr(1 To 65535, 1 To 1)
  Dim i As Long, j As Long, TG As Double
  TG = Timer
  With Sheets("Data")
    .Range("D2:D65536").ClearContents
    Src = .Range("A2:A65536").Value
    With CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Src)
        If Not .Exists(Src(i, 1)) Then
          j = j + 1
          .Add Src(i, 1), ""
          Arr(j, 1) = Src(i, 1)
        End If
      Next
    End With
    If j > 0 Then
      With .Range("D2").Resize(j)
        .Value = Arr
        .Sort .Cells(1, 1), 1, Header:=xlNo
      End With
    End If
  End With
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

 

[le tin]

Cảm ơn NDU nhiều , tốc độ quá ok , mình chưa thấy giải pháp nào hơn . Trên cơ sở đó mình thêm 1 yêu cầu nhưng mãi vẫn chưa được . Nhờ bạn xem file giúp tí nữa .

 

[ndu96081631]

Cảm ơn NDU nhiều , tốc độ quá ok , mình chưa thấy giải pháp nào hơn . Trên cơ sở đó mình thêm 1 yêu cầu nhưng mãi vẫn chưa được . Nhờ bạn xem file giúp tí nữa .

Bạn hỏi:

Tìm bên cột A sheet2 có số trùng với cột D sheet1 với điều kện cột B sheet2 = a
Cho kết quả tổng ở cột F

Không biêt có nhằm hay không? theo tôi là Tìm bên cột A sheet2 có số trùng với cột A sheet1 mới đúng chứ ---> Vì cột D sheet 1 là kết quả cơ mà

 

[le tin]

Bạn hỏi:

Không biêt có nhằm hay không? theo tôi là Tìm bên cột A sheet2 có số trùng với cột A sheet1 mới đúng chứ ---> Vì cột D sheet 1 là kết quả cơ mà

Không nhầm đâu bạn , tức là sau khi có kết quả ở D sheet1 rồi , làm động tác tiếp là lấy tổng từ C sheet2 với điều kiện có mã trùng và = a

 

[ndu96081631]

Không nhầm đâu bạn , tức là sau khi có kết quả ở D sheet1 rồi , làm động tác tiếp là lấy tổng từ C sheet2 với điều kiện có mã trùng và = a

Sửa code cũ lại 1 tí là được:

Sub NDU()
  Dim Src1, Src2, Arr(1 To 65535, 1 To 3)
  Dim Tmp, i As Long, j As Long, TG As Double
  TG = Timer
  With Sheet1.Range("A2:C65536")
    Src1 = .Value
    .Resize(, 1).Offset(, 3).NumberFormat = "@"
  End With
  Src2 = Sheet2.Range("A2:C65536").Value
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Src1)
      If Len(Src1(i, 1)) = 12 Then
        If Src1(i, 2) = "a" Then
          If Src1(i, 3) > 4 Then
            Tmp = Src1(i, 1)
            If Not .Exists(Tmp) Then
              j = j + 1
              .Add Tmp, j
              Arr(j, 1) = Tmp
              Arr(j, 2) = Src1(i, 3)
            Else
              Arr(.Item(Tmp), 2) = Val(Arr(.Item(Tmp), 2)) + Val(Src1(i, 3))
            End If
          End If
        End If
      End If
    Next
    For i = 1 To UBound(Src2)
      If Src2(i, 2) = "a" Then
        Tmp = Src2(i, 1)
        If .Exists(Tmp) Then Arr(.Item(Tmp), 3) = Arr(.Item(Tmp), 3) + Src2(i, 3)
      End If
    Next
  End With
  Range("D2").Resize(j, 3).Value = Arr
  MsgBox Format(Timer - TG, "0.000000000")
End Sub

Bạn để ý, tôi thêm 1 vòng lập nữa, thuật toán cũng dể hiểu thôi mà
Diển giải bằng lời:
- Duyệt dữ liệu sheet2 từ trên xuống
- Nếu cột 2 = "a" thì đặt giá trị cột 1 là Tmp
- Xét sự tồn tại của Tmp trong Dictionary Object, nếu có tồn tại thì nạp giá trị cột 3 vào mảng Arr (đúng vị trí) và cộng dồn
Vậy thôi