Copy code có chiều dài 12

[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

 

[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