Cần lọc dữ liệu sang các trang tính khác theo yêu cầu (1 người xem)

  • Thread starter Thread starter vansontv
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
vansontv đã viết:
mình sử dụng được công thức của bạn rồi nhưng có chổ 3 sao Vân Hớn Thổ Tú Thái Âm nó nằm trung 1 sheet phải làm sao bạn
Nhấp chuột vào đây để mở rộng...
Trong khi đơi bạn @HieuCD ra tay thì bạn dùng tạm code này vậy. Mình không có dữ liệu 10000 dòng nên không biết code có nhanh không nửa, bạn tự test thử vậy.
 

File đính kèm

giaiphap đã viết:
Trong khi đơi bạn @HieuCD ra tay thì bạn dùng tạm code này vậy. Mình không có dữ liệu 10000 dòng nên không biết code có nhanh không nửa, bạn tự test thử vậy.
Nhấp chuột vào đây để mở rộng...
hay vậy cho nó auto không cần nhấn cái ô màu xanh được không bạn thêm cái nửa bên sheet La Hầu Thái Bạch Kế Đô v/v cái cột E và Cột F không cần lọc qua đâu chỉ cần Tên Họ, tuổi 2 cột Nam Nữ và cột Sao là được rồi
 
chết rồi minh viết "Sao Hạng lên thiếu rồi
La Hầu

Thổ Tú

Thủy Diệu

Thái Bạch

Thái Dương

Vân Hớn

Kế Đô

Thái Âm

Mộc Đức

như vậy đó lọc 3 cái chính còn những sao còn lại vào sao hội
 
vansontv đã viết:
hay vậy cho nó auto không cần nhấn cái ô màu xanh được không bạn thêm cái nửa bên sheet La Hầu Thái Bạch Kế Đô v/v cái cột E và Cột F không cần lọc qua đâu chỉ cần Tên Họ, tuổi 2 cột Nam Nữ và cột Sao là được rồi
Nhấp chuột vào đây để mở rộng...
Auto cũng được bạn, nhưng bạn cứ tưởng voi thế này nhé. Giả sử bạn gõ 1 ô, sau đó nhấn Enter code sẽ duyệt qua 10000 lần để quét dữ liệu bạn và 10000 lần kiểm tra điều kiện, sau đó lọc lấy dữ liệu thỏa mãn ghi vào 4 sheet và kẻ khung luôn, thời gian tiêu tốn 15 giây (giả sử thôi nhé). Vậy gõ 1 ô và phải đợi 15 giây sau mới được phép gõ nửa bạn có kiên nhẫn làm việc với nó không? Nếu có tôi sẽ giúp.
 
Mộng Thường 2001 đã viết:
không ai trách bạn gì cả! chẳng qua bạn đặt tiêu đề không cụ thể sai với nội quy diễn đàn nên phải khóa bài thôi!
bạn xem file đính kèm là cách dùng công thức nhen! hihi ^o^
Nhấp chuột vào đây để mở rộng...
Cho mình góp vui tý xíu :p
Tại sheet nhập công thức rút lại cho gọn
E5=IFERROR(CHOOSE(MOD(C5,9),"La Hầu","Thổ Tú","Thủy Diệu","Thái Bạch","Thái Dương","Văn Hớn","Kế Đô","Thái Âm","Mộc Đức"),"")
F5=IFERROR(CHOOSE(MOD(D5,9),"Kế Đô","Văn Hớn","Mộc Đức","Thái Âm","Thổ Tú","La Hầu","Thái Dương","Thái Bạch","Thủy Diệu"),"")
 

File đính kèm

giaiphap đã viết:
Bạn @HieuCD ra tay giúp luôn phần code đi cho nó máu, tôi thấy chủ đề dưới có code sẳn rồi sửa chút cho học hỏi thêm luôn đi.
http://www.giaiphapexcel.com/diendan/threads/tách-file-danh-sách-học-sinh-theo-lớp-từ-sheet-tổng.133620/#post-845563
Nhấp chuột vào đây để mở rộng...
Code của mình rất nhiều phần là học hỏi từ bạn :)
vansontv đã viết:
hay vậy cho nó auto không cần nhấn cái ô màu xanh được không bạn thêm cái nửa bên sheet La Hầu Thái Bạch Kế Đô v/v cái cột E và Cột F không cần lọc qua đâu chỉ cần Tên Họ, tuổi 2 cột Nam Nữ và cột Sao là được rồi
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String
  Application.ScreenUpdating = False
 
  sArr = Array("La H?u", "Thái B?ch", "K? ?ô", "Sao H?i")
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To Sheets.Count 'lay Index sheets
    For n = 0 To 3
      tmp = sArr(n)
      If Sheets(i).Name Like tmp Then Dic.Item(tmp) = i: Exit For
    Next n
  Next i
 
  Set Sh = Sheets(Dic.Item(sArr(3))) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    .Range("A5:G" & lRow).Copy Destination:=Sh.Range("A5")
  End With
 
  Set RngList = Sh.Range("A4:G" & lRow)
  Set Rng = Sh.Range("A5:G" & lRow)
  Rng.Value = Rng.Value
  Sh.Range("E5:F" & lRow).Value = Empty
 
  For i = 0 To 2
    ik = Dic.Item(sArr(i))
    With Sheets(ik)
      lRow = .Range("B" & Rows.Count).End(xlUp).Row
      If lRow > 4 Then .Range("A5:G" & lRow).Clear
      RngList.AutoFilter Field:=7, Criteria1:=sArr(i)
      If Rng.SpecialCells(12).Cells.Count Then
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
        RngList.AutoFilter
      End If
    End With
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

HieuCD đã viết:
Code của mình rất nhiều phần là học hỏi từ bạn :)

Chạy code
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String
  Application.ScreenUpdating = False
 
  sArr = Array("La H?u", "Thái B?ch", "K? ?ô", "Sao H?i")
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To Sheets.Count 'lay Index sheets
    For n = 0 To 3
      tmp = sArr(n)
      If Sheets(i).Name Like tmp Then Dic.Item(tmp) = i: Exit For
    Next n
  Next i
 
  Set Sh = Sheets(Dic.Item(sArr(3))) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    .Range("A5:G" & lRow).Copy Destination:=Sh.Range("A5")
  End With
 
  Set RngList = Sh.Range("A4:G" & lRow)
  Set Rng = Sh.Range("A5:G" & lRow)
  Rng.Value = Rng.Value
  Sh.Range("E5:F" & lRow).Value = Empty
 
  For i = 0 To 2
    ik = Dic.Item(sArr(i))
    With Sheets(ik)
      lRow = .Range("B" & Rows.Count).End(xlUp).Row
      If lRow > 4 Then .Range("A5:G" & lRow).Clear
      RngList.AutoFilter Field:=7, Criteria1:=sArr(i)
      If Rng.SpecialCells(12).Cells.Count Then
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
        RngList.AutoFilter
      End If
    End With
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
po tay rồi bạn ơi ctrl + shift + T không hiện lên cái gì hết chạy code như nào vậy hay la bấm ctrl + shift + T không bấm mặt cười mình gà cái này giúp giúp người giúp cho chót luôn y bạn làm hộ mình ra bản excel hoàng chỉnh y người khi mình không ở đó mấy Sư tự làm cũng đuơcj
 
vansontv đã viết:
po tay rồi bạn ơi ctrl + shift + T không hiện lên cái gì hết chạy code như nào vậy hay la bấm ctrl + shift + T không bấm mặt cười mình gà cái này giúp giúp người giúp cho chót luôn y bạn làm hộ mình ra bản excel hoàng chỉnh y người khi mình không ở đó mấy Sư tự làm cũng đuơcj
Nhấp chuột vào đây để mở rộng...
ctrl + shift + T chỉ chạy được trên file của mình thôi
gởi file của bạn lên, mình sẽ làm cho chạy code
 
không đợc
HieuCD đã viết:
ctrl + shift + T chỉ chạy được trên file của mình thôi
gởi file của bạn lên, mình sẽ làm cho chạy code
Nhấp chuột vào đây để mở rộng...
ok bạn đợi chúc thêm cái nửa nếu xoa bên sheet nhập thì những sheet kia tự xóa luôndduocuoc không ban
 

File đính kèm

bửa nay ngủ sớm rồi
 
HieuCD đã viết:
Xóa bên sheet nhập là như thế nào? Xóa dữ liệu hay xóa cả sheet?
Nhấp chuột vào đây để mở rộng...
xóa dữ liệu thôi bạn mình nhập bên sheet nhập thì nó lọc qua mình xóa bên nhập nó cũng xóa luôn đợc ko bạn nếu không đợc thì mình xóa tay cũng được
 
vansontv đã viết:
xóa dữ liệu thôi bạn mình nhập bên sheet nhập thì nó lọc qua mình xóa bên nhập nó cũng xóa luôn đợc ko bạn nếu không đợc thì mình xóa tay cũng được
Nhấp chuột vào đây để mở rộng...
Lưu file với đuôi .xlsm hay .xlsb
Insert Module và chép code vào
Tìm biểu tượng Macro trong Excel, bấm biểu tượng
Chọn sub, chọn Options, nhập phím tắt vào Shortcut key, nhớ kết quả, nhấn Enter
Sheet Sao Hội không được xóa
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
    Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  End With
 
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
        RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
Private Function TestSheet(ShName As String) As Boolean
  On Error Resume Next
  ShName = Sheets(ShName).Name
  If Err.Number Then TestSheet = True
  On Error GoTo 0
End Function
 

File đính kèm

HieuCD đã viết:
Lưu file với đuôi .xlsm hay .xlsb
Insert Module và chép code vào
Tìm biểu tượng Macro trong Excel, bấm biểu tượng
Chọn sub, chọn Options, nhập phím tắt vào Shortcut key, nhớ kết quả, nhấn Enter
Sheet Sao Hội không được xóa
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
    Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  End With
 
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
        RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
Private Function TestSheet(ShName As String) As Boolean
  On Error Resume Next
  ShName = Sheets(ShName).Name
  If Err.Number Then TestSheet = True
  On Error GoTo 0
End Function
Nhấp chuột vào đây để mở rộng...
để mình mò chứ cái Insert Module không biết cái gì nửa thanks bạn nhiều nhé :help:
 
được rồi bạn tài quá bạn cho mình hỏi thêm cái nửa thấy cái rút gọn này hay nè nhưng cái sao cuối cùng cửa E5 và F5 nó không tính E5=IFERROR(CHOOSE(MOD(C5,9),"La Hầu","Thổ Tú","Thủy Diệu","Thái Bạch","Thái Dương","Văn Hớn","Kế Đô","Thái Âm","Mộc Đức"),"")
F5=IFERROR(CHOOSE(MOD(D5,9),"Kế Đô","Văn Hớn","Mộc Đức","Thái Âm","Thổ Tú","La Hầu","Thái Dương","Thái Bạch","Thủy Diệu"),"") sao Mộc Đức và Thủy Diệu
HieuCD đã viết:
Lưu file với đuôi .xlsm hay .xlsb
Insert Module và chép code vào
Tìm biểu tượng Macro trong Excel, bấm biểu tượng
Chọn sub, chọn Options, nhập phím tắt vào Shortcut key, nhớ kết quả, nhấn Enter
Sheet Sao Hội không được xóa
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
    Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  End With
 
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
        RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
Private Function TestSheet(ShName As String) As Boolean
  On Error Resume Next
  ShName = Sheets(ShName).Name
  If Err.Number Then TestSheet = True
  On Error GoTo 0
End Function
Nhấp chuột vào đây để mở rộng...
 
công thức đó làm được rồi bạn chỉ thêm cái nửa dùm mình luôn nhé là bên sheet nhập không bật caps lock nhưng khi mình lọc qua bên những sheet kia tên người viết Hoa chữ cái đầu được không bạn
HieuCD đã viết:
Lưu file với đuôi .xlsm hay .xlsb
Insert Module và chép code vào
Tìm biểu tượng Macro trong Excel, bấm biểu tượng
Chọn sub, chọn Options, nhập phím tắt vào Shortcut key, nhớ kết quả, nhấn Enter
Sheet Sao Hội không được xóa
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range, sArr As Variant, Dic As Object
  Dim i As Long, ik As Long, n As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
    Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  End With
 
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
        RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Application.ScreenUpdating = True
End Sub
Private Function TestSheet(ShName As String) As Boolean
  On Error Resume Next
  ShName = Sheets(ShName).Name
  If Err.Number Then TestSheet = True
  On Error GoTo 0
End Function
Nhấp chuột vào đây để mở rộng...
 
vansontv đã viết:
công thức đó làm được rồi bạn chỉ thêm cái nửa dùm mình luôn nhé là bên sheet nhập không bật caps lock nhưng khi mình lọc qua bên những sheet kia tên người viết Hoa chữ cái đầu được không bạn
Nhấp chuột vào đây để mở rộng...
Dùng code
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range
  Dim sArr As Variant, dArr As Variant
  Dim i As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  Sh.AutoFilterMode = False
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    .AutoFilterMode = False
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
  End With
 
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  dArr = Sh.Range("B5:B" & lRow).Value
  For i = 1 To UBound(dArr)
    dArr(i, 1) = Application.Proper(dArr(i, 1))
  Next i
  Sh.Range("B5:B" & lRow) = dArr
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
      RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Set Sh = Nothing: Set RngList = Nothing: Set Rng = Nothing
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

bạn quá giỏi rồi cầu chúc cho bạn có nhiều sức khỏe để giúp đở mọi người
HieuCD đã viết:
Dùng code
Mã: 
Sub TachSao()
  'Nhan 3 phím: Ctrl + Shift + T chay code
  Dim Sh As Worksheet, RngList As Range, Rng As Range
  Dim sArr As Variant, dArr As Variant
  Dim i As Long, lRow As Long
  Dim tmp As String, ShName As String
  Application.ScreenUpdating = False
  sArr = Array("La H" & ChrW(7847) & "u", "Thái B" & ChrW(7841) & "ch", "K" & ChrW(7871) & " " & ChrW(272) & "ô", "Sao H" & ChrW(7897) & "i")
 
  Set Sh = Sheets(sArr(3)) 'Sheet Sao Hoi"
  Sh.AutoFilterMode = False
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then Sh.Range("A5:G" & lRow).Clear
 
  With Sheet1
    .AutoFilterMode = False
    lRow = .Range("G" & Rows.Count).End(xlUp).Row
    If lRow < 5 Then MsgBox ("Khong co du lieu, Khong Sao"): Exit Sub
    Sh.Range("A5:D" & lRow).Value = .Range("A5:D" & lRow).Value
    Sh.Range("E5:E" & lRow).Value = .Range("G5:G" & lRow).Value
  End With
 
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  dArr = Sh.Range("B5:B" & lRow).Value
  For i = 1 To UBound(dArr)
    dArr(i, 1) = Application.Proper(dArr(i, 1))
  Next i
  Sh.Range("B5:B" & lRow) = dArr
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
 
  For i = 0 To 2
    ShName = sArr(i)
    RngList.AutoFilter Field:=5, Criteria1:=ShName
    If Rng.SpecialCells(xlCellTypeLastCell).Row > 4 Then
      If TestSheet(ShName) Then
        Set ShMain = Sheets.Add(After:=Sheets(Sheets.Count))
        Sheets(Sheets.Count).Name = ShName
        Sh.Range("A1:E4").Copy Destination:=Sheets(ShName).Range("A1")
      End If
      With Sheets(ShName)
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        If lRow > 4 Then .Range("A5:E" & lRow).Clear
        Rng.SpecialCells(12).Copy Destination:=.Range("A5")
        Rng.EntireRow.Delete
        lRow = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A5").Value = 1
        .Range("A5:A" & lRow).DataSeries
      End With
      RngList.AutoFilter
    Else
      Sheets(ShName).Delete
    End If
  Next i
 
  lRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
  If lRow > 4 Then
    Sh.Range("A5").Value = 1
    Sh.Range("A5:A" & lRow).DataSeries
  End If
  Set Sh = Nothing: Set RngList = Nothing: Set Rng = Nothing
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

G
Xin Code xóa Module.
Trả lời
11
Đọc
441
GCQ
G
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet
Trả lời
4
Đọc
125
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
    • Thích
Trả lời
1
Đọc
876
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
69
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện (2 người xem)
Trả lời
5
Đọc
121
LePhatHuy
LePhatHuy
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản. (1 người xem)
Trả lời
9
Đọc
195
duongbabao90
D
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
327
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
393
tle2003
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
17
Đọc
499
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
23
Đọc
764
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025
Trả lời
8
Đọc
216
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
128
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
178
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
2
Đọc
266
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
223
DeTong
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom