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

 

[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