Lọc trích có điều kiện và copy sang sheet mới

[dammeexcel]

Mình đang có bài đau đầu. Mình muốn công việc nhanh đở tốn thời gian một chút. Mong các bạn giúp với.
Đó là một bài gồm nhiều sheet muốn lọc sang 1 sheet kèm điều kiện.
Nội dung đã có sẵn trong file kèm. CÁc bạn giúp. Cảm ơn nhiều

 

[ChanhTQ@]

Hỏi lại cho rõ:

(1) Nếu TS là 10.93 & Fat là 2.93 thì xếp ưu tiên vô trang nào?

(2) Số liệu trong các trang TN(i) sẽ fát sinh như thế nào, từng record hay hàng loạt?


Chờ tin từ bạn!

 

[lifewithit]

(1):Nếu TS có số liệu nằm ở loai D còn Fat nằm ở loại E (hoặc ngược lại) thì xếp loại E (loại E thấp hơn loại D)
(2): Số liệu trong các trang TN (i) sẽ thay đổi hàng tuần: ID vẫn như cũ, Tất cả định dạng vẫn như cũ giống vậy, chỉ có số liệu thì thay đổi.

 

[SA_DQ]

Bạn kiểm trong file đính kèm nha

Bấm tổ hợp {CTRL}+{SHIFT}+C khi muốn macro cập nhật dữ liệu mới

 

[dammeexcel]

Mình muốn dữ liệu sau khi lọc qua sheet LOAI D và LOAI E thì ở 2 sheet này sẽ tự động sort từ nhỏ đến lớn theo cột TS được ko ?

Điều nữa là trong sheet LOAI D và LOAI E sau khi lọc xog ở phần ID các ô bị tô nhiều màu wa. Mình muốn nó vẫn là màu trắng bình thường được ko ?

Mình muốn cố định dòng tiêu đề: ID, Sub, TS, Fat ... trong 2 sheet loại D và loai E (tức không cho xóa) được không, chỉ xóa các số sau khi lọc thì được ?

Mong các bạn giúp

 

[ThuNghi]

Mình muốn dữ liệu sau khi lọc qua sheet LOAI D và LOAI E thì ở 2 sheet này sẽ tự động sort từ nhỏ đến lớn theo cột TS được ko ?
Điều nữa là trong sheet LOAI D và LOAI E sau khi lọc xog ở phần ID các ô bị tô nhiều màu wa. Mình muốn nó vẫn là màu trắng bình thường được ko ?

Mình muốn cố định dòng tiêu đề: ID, Sub, TS, Fat ... trong 2 sheet loại D và loai E (tức không cho xóa) được không, chỉ xóa các số
sau khi lọc thì được ?

Mong các bạn giúp

1/ Sau khi lọc xong thì sort lại.
2/ Vào code dòng nào có câu .Interior.ColorIndex thì bỏ đi.
3/ Hình như là cố định tiêu đề rồi mà.

 

[dammeexcel]

Sao mình đổi tên sheet TN1, TN2, TN3,.. thành tên khác vd: Ab, Cd,... thì nó ko chạy được vậy giúp với

 

[iVBA]

Sao mình đổi tên sheet TN1, TN2, TN3,.. thành tên khác vd: Ab, Cd,... thì nó ko chạy được vậy giúp với

Nếu bạn muốn đổi tên Sheet thì phải phải sửa ở trong code nữa đó bạn.

 

[dammeexcel]

SỮA SAO BẠN.
cHỖ NÀO GIÚP MÌNH VỚI NHA

Option Explicit
Sub CopyData()
Dim Rws As Long, jJ As Byte
Dim Sh As Worksheet, ShE As Worksheet, ShD As Worksheet
Dim Cls As Range, Rng As Range
Dim ShName As String

For jJ = 1 To 2
ShName = "LOAI " & Choose(jJ, "D", "E")
Set Sh = Sheets(ShName)
Rws = [A65500].End(xlUp).Row
Sh.[A5].Resize(Rws, 20).ClearContents
Next jJ
Set ShE = Sheets("LOAI E"): Set ShD = Sheets("LOAI D")
Application.ScreenUpdating = False
For Each Sh In ThisWorkbook.Worksheets
If Left(Sh.Name, 1) = "T" Then
Rws = Sh.[E65500].End(xlUp).Row
Set Rng = Sh.[E2].Resize(Rws)
For Each Cls In Rng
If (Cls.Value >= 10.5 And Cls.Value < 11) _
Or (Cls.Offset(, 1).Value >= 2.5 And Cls.Offset(, 1).Value < 2.7) Then
With ShE.[A65500].End(xlUp).Offset(1)
.Resize(, 20).Value = Sh.Cells(Cls.Row, "A").Resize(, 20).Value
.Interior.ColorIndex = 33 + Right(Sh.Name, 1)
End With
ElseIf (Cls.Value >= 11 And Cls.Value < 11.4) _
Or (Cls.Offset(, 1).Value >= 2.7 And Cls.Offset(, 1).Value < 3) Then
With ShD.[A65500].End(xlUp).Offset(1)
.Resize(, 20).Value = Sh.Cells(Cls.Row, "A").Resize(, 20).Value
.Interior.ColorIndex = 33 + Right(Sh.Name, 1)
End With
End If
Next Cls
End If

Next Sh
End Sub

 

[ThuNghi]

Sao mình đổi tên sheet TN1, TN2, TN3,.. thành tên khác vd: Ab, Cd,... thì nó ko chạy được vậy giúp với

Thì đổi code 1 chút vậy thay vì

if left(sh.name,1)="T"

thành

if left(sh.name,4)<>"Loai"

Hay bạn dùng thử code sau:

Option Explicit
Sub LocData()
Dim Sh As Worksheet, ShName As String, myRng As Range
Dim Arr(), ArrTS(), ArrFat(), ArrE(), ArrD()
Dim endR As Long, i As Long, sD As Long, sE As Long, k As Long
Dim TsD1 As Double, TsD2 As Double, FatD1 As Double, FatD2 As Double
Dim TsE1 As Double, TsE2 As Double, FatE1 As Double, FatE2 As Double
Dim wf As WorksheetFunction
Set wf = WorksheetFunction
With Sheets("Loai E")
  TsE1 = .[A2]: TsE2 = .[B2]: FatE1 = .[C2]: FatE1 = .[D2]:
  .Range("A5:Q65000").ClearContents
End With
With Sheets("Loai D")
  TsD1 = .[A2]: TsD2 = .[B2]: FatD1 = .[C2]: FatD1 = .[D2]:
  .Range("A5:Q65000").ClearContents
End With
sE = 0: sD = 0
For Each Sh In ThisWorkbook.Worksheets
  With Sh
    If UCase(Left(.Name, 4)) <> UCase("Loai") Then
      endR = .[E65500].End(xlUp).Row
      Arr = .Range("A2:Q" & endR).Value
      ArrTS = wf.Transpose(.Range("E2:E" & endR).Value)
      ArrFat = wf.Transpose(.Range("F2:F" & endR).Value)
      For i = 1 To UBound(ArrFat)
        If (ArrFat(i) > FatE1 And ArrFat(i) < FatE2) Or (ArrTS(i) > TsE1 And ArrTS(i) < TsE2) Then
          sE = sE + 1
          ReDim Preserve ArrE(1 To 17, 1 To sE)
          For k = 1 To 17
            ArrE(k, sE) = Arr(i, k)
          Next k
          GoTo Next_i
        End If
        If (ArrFat(i) > FatD1 And ArrFat(i) < FatD2) Or (ArrTS(i) > TsD1 And ArrTS(i) < TsD2) Then
          sD = sD + 1
          ReDim Preserve ArrD(1 To 17, 1 To sD)
          For k = 1 To 17
            ArrD(k, sD) = Arr(i, k)
          Next k
        End If
Next_i:
      Next i
    End If
  End With
Next Sh
With Sheets("Loai E")
  If sE > 0 Then
    .[A5].Resize(sE, 17) = wf.Transpose(ArrE)
    Set myRng = .[A5].Resize(sE, 17)
    With myRng
      .Sort Key1:=.Cells(1, 5), Order1:=xlAscending, Header:=xlNo
    End With
  End If
End With
With Sheets("Loai D")
  If sD > 0 Then
    .[A5].Resize(sD, 17) = wf.Transpose(ArrD)
    Set myRng = .[A5].Resize(sD, 17)
    With myRng
      .Sort Key1:=.Cells(1, 5), Order1:=xlAscending, Header:=xlNo
    End With
  End If
End With
Set myRng = Nothing: Set wf = Nothing
Erase Arr(), ArrTS(), ArrFat(), ArrE(), ArrD()
End Sub

Code hơi dài 1 chút do mới học theo NDU chuyển thành mảng 1 chiều.