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)
giaiphap đã viết:
Tôi đã nói lúc đầu rồi mà, nhờ đúng người rồi đó.
Nhấp chuột vào đây để mở rộng...
cũng thanks bạn luôn nhé chúc các bạn có nhiều sức khỏe giúp đỡ m.n bạn có tinh Phật không nếu tinh Phật các bạn đã giúp tôi tạo cái file đó là giúp quý Thầy giúp m.n theo Đạo Phật là Công Đức Vô Lượng Đó A Di Đà Phật mong chư Phật gia hộ các bạn
 
gập cao nhân hỏi cho tới luôn có thể cho Số TT bên mấy sheet lọc căn giửa luôn Tên hạ căn trái ô kẻ bung dừa luôn và chổ Tuổi Nam Nữ căn Giữa luôn cái cuối này nừa là hoàn chỉnh rồi giúp luôn he bạn
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...
 
vansontv đã viết:
gập cao nhân hỏi cho tới luôn có thể cho Số TT bên mấy sheet lọc căn giửa luôn Tên hạ căn trái ô kẻ bung dừa luôn và chổ Tuổi Nam Nữ căn Giữa luôn cái cuối này nừa là hoàn chỉnh rồi giúp luôn he bạn
Nhấp chuột vào đây để mở rộng...
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
 
  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
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  Sh.Range("A5:E" & lRow).Font.Size = 12
  Sh.Range("A5:A" & lRow).HorizontalAlignment = xlCenter
  Sh.Range("C5:D" & lRow).HorizontalAlignment = xlCenter
 
  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
        .Columns("A:E").EntireColumn.AutoFit
      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
    Sh.Columns("A:E").EntireColumn.AutoFit
  End If
  Set Sh = Nothing: Set RngList = Nothing: Set Rng = Nothing
  Application.ScreenUpdating = True
End Sub
 
thay code này vào cũng y như code kia bạn ơi thôi vậy cũng được thaks bạn
HieuCD đã viết:
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
 
  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
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  Sh.Range("A5:E" & lRow).Font.Size = 12
  Sh.Range("A5:A" & lRow).HorizontalAlignment = xlCenter
  Sh.Range("C5:D" & lRow).HorizontalAlignment = xlCenter
 
  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
        .Columns("A:E").EntireColumn.AutoFit
      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
    Sh.Columns("A:E").EntireColumn.AutoFit
  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ác @HieuCD ơi giúp mình lại cái lên office 2019 lỗi rồi xin bác giúp làm lại nhé mới đem ra chửng bị qua tết dùng thì lỗi nhờ kiểm tra lại không để tới lúc làm là po tay rồi

xóa lỗi dome
Chưa có tê fxvdsn.pngChưa có tê fxvdsn.png
nhập lỗi dome
Chưa cóbdbd tên.pngChưa có tê fxvdsn.pngChưa cóbdbd tên.png
 
vansontv đã viết:
bác @HieuCD ơi giúp mình lại cái lên office 2019 lỗi rồi xin bác giúp làm lại nhé mới đem ra chửng bị qua tết dùng thì lỗi nhờ kiểm tra lại không để tới lúc làm là po tay rồi

xóa lỗi dome
View attachment 211683View attachment 211683
nhập lỗi dome
View attachment 211684View attachment 211683View attachment 211684
Nhấp chuột vào đây để mở rộng...
Không có office 2019 để kiểm tra, Khi nào máy tính đồ cổ bị bứt tử mới cài lại
Khả năng là các sheet bị thay đổi nên VBA phản ứng thái quá, cầm tay bắt mạch mới biết bệnh
 
mình không có chỉnh sửa gì trong đó chỉ tải bản chỉnh sửa của bạn và add code vào thôi lúc office 2016 chạy bình thường nên mình để nguyên vậy giờ nhà chùa chửng bị sài mình mở xem lại thì lỗi không biết tại office 2019 hay gì thì mình không biết nửa bạn sài win gì năng officw lên đi :)
HieuCD đã viết:
Không có office 2019 để kiểm tra, Khi nào máy tính đồ cổ bị bứt tử mới cài lại
Khả năng là các sheet bị thay đổi nên VBA phản ứng thái quá, cầm tay bắt mạch mới biết bệnh
Nhấp chuột vào đây để mở rộng...
 
vansontv đã viết:
mình không có chỉnh sửa gì trong đó chỉ tải bản chỉnh sửa của bạn và add code vào thôi lúc office 2016 chạy bình thường nên mình để nguyên vậy giờ nhà chùa chửng bị sài mình mở xem lại thì lỗi không biết tại office 2019 hay gì thì mình không biết nửa bạn sài win gì năng officw lên đi :)
Nhấp chuột vào đây để mở rộng...
Mình dùng Excel 2007, bạn đem file sang máy khác chạy xem có bị lổi không, nếu vẫn bị thì gởi file cho mình xem lại
 
HieuCD đã viết:
Mình dùng Excel 2007, bạn đem file sang máy khác chạy xem có bị lổi không, nếu vẫn bị thì gởi file cho mình xem lại
Nhấp chuột vào đây để mở rộng...
nhà chùa không có máy cái laptop của mình thì office 2019 po tay rồi key office 2019 và win10 kích hoạt nhiều lắm bác năng lên đi mình có thể hổ trợ bạn kích hoạt :)
 
vansontv đã viết:
nhà chùa không có máy cái laptop của mình thì office 2019 po tay rồi key office 2019 và win10 kích hoạt nhiều lắm bác năng lên đi mình có thể hổ trợ bạn kích hoạt :)
Nhấp chuột vào đây để mở rộng...
Máy mình yếu quá, cài Office 2010 và win mới thì chạy chậm, nên vẫn dùng các phiên bản xưa
Bài đã được tự động gộp:

vansontv đã viết:
nhà chùa không có máy cái laptop của mình thì office 2019 po tay rồi key office 2019 và win10 kích hoạt nhiều lắm bác năng lên đi mình có thể hổ trợ bạn kích hoạt :)
Nhấp chuột vào đây để mở rộng...
Bạn nhắn tin cho bạn Befaint, nhờ kiểm tra trên máy xem sao, có thể lập Temp view xem trực tiếp trên máy
 
Lần chỉnh sửa cuối:
HieuCD đã viết:
Máy mình yếu quá, cài Office 2010 và win mới thì chạy chậm, nên vẫn dùng các phiên bản xưa
Bài đã được tự động gộp:


Bạn nhắn tin cho bạn Befaint, nhờ kiểm tra trên máy xem sao, có thể lập Temp view xem trực tiếp trên máy
Nhấp chuột vào đây để mở rộng...
Anh Hiếu ơi nghỉ tết đi anh.:D.
 
HieuCD đã viết:
Máy mình yếu quá, cài Office 2010 và win mới thì chạy chậm, nên vẫn dùng các phiên bản xưa
Bài đã được tự động gộp:


Bạn nhắn tin cho bạn Befaint, nhờ kiểm tra trên máy xem sao, có thể lập Temp view xem trực tiếp trên máy
Nhấp chuột vào đây để mở rộng...
kiếm được máy test rồi lỗi trên office 2019 thôi 2016 chạy bình thường
 
HieuCD đã viết:
Đã chuẩn bị mọi việc, lên mạng giải lao
Nhấp chuột vào đây để mở rộng...
thôi bác nghĩ tết đi mình chiệu khó quay tay vậy tại muốn giúp cho mọi người làm việc nhanh hơn nhưng office 2019 không chạy thì chiệu rồi thanks bác đã nhiệt tình giúp mình chúc bạn một năm mới có nhiều sức khỏe và hạnh phúc phát tài phát lộc
 
qua tết bạn rảnh làm lại dùm mình he
cái này mình chụp lại khi xóa nội dung bị lỗi
xoa bi loi.png
bấm Debug vào trong
trong vba.png
còn ở ngoài thì nó bỏ 2 sheet không xoa
khong xoa.png
 
HieuCD đã viết:
Không có office 2019 để kiểm tra, Khi nào máy tính đồ cổ bị bứt tử mới cài lại
Khả năng là các sheet bị thay đổi nên VBA phản ứng thái quá, cầm tay bắt mạch mới biết bệnh
Nhấp chuột vào đây để mở rộng...
bạn nói đúng rồi bấm Ctel + Shift +T nó thêm sheet Thái Bạch nhưng lỗi font mình không biết nhiều về excel nên không hiểu vba po tay
Chưa có tên.png
 
vansontv đã viết:
bạn nói đúng rồi bấm Ctel + Shift +T nó thêm sheet Thái Bạch nhưng lỗi font mình không biết nhiều về excel nên không hiểu vba po tay
View attachment 211921
Nhấp chuột vào đây để mở rộng...
Do bộ Font khác rồi
Chỉnh lại Code như trong file, xóa các sheet khác chỉ giữ lại 2 sheet như trong file, lưu ý tên sheet mới là "Sao Hoi" không có dấu tiếng Việt
 

File đính kèm

HieuCD đã viết:
Do bộ Font khác rồi
Chỉnh lại Code như trong file, xóa các sheet khác chỉ giữ lại 2 sheet như trong file, lưu ý tên sheet mới là "Sao Hoi" không có dấu tiếng Việt
Nhấp chuột vào đây để mở rộng...
mình cũng không hiểu sao nữa đem qua office 2016 chạy bình thường nhưng máy mình bị lỗi vba chạy font nào vậy bạn cũng lỗi
chạy code rồi bấm mặt cười nó hiện bản báo không tìm thấy ô
Chưa có tên.png
Chưa ccó tên.png
nó mắt sao kế đô rồi
Chưa cdcó tên.png
 
vansontv đã viết:
mình cũng không hiểu sao nữa đem qua office 2016 chạy bình thường nhưng máy mình bị lỗi vba chạy font nào vậy bạn cũng lỗi
chạy code rồi bấm mặt cười nó hiện bản báo không tìm thấy ô
View attachment 211936
View attachment 211937
nó mắt sao kế đô rồi
View attachment 211938
Nhấp chuột vào đây để mở rộng...
Mình dùng font Unicode của window
Ngoài "Kế Đô" còn có sao nào dạng "K? ??" không, nếu có code sẽ gôm vào cùng 1 sao
Chỉnh dòng lệnh
Sao = Array("La H?u", "Thái B?ch", "K? ??", "Sao H?i")
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, Sao As Variant, dArr As Variant
  Dim i As Long, lRow As Long
  Dim tmp As String, ShName As String, TenSao As String
  Application.ScreenUpdating = False
  Sao = Array("La H?u", "Thái B?ch", "K? ??", "Sao H?i")
  sArr = Array("La Hau", "Thai Bach", "Ke Do", "Sao Hoi")
 
  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
 
  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
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  Sh.Range("A5:E" & lRow).Font.Size = 12
  Sh.Range("A5:A" & lRow).HorizontalAlignment = xlCenter
  Sh.Range("C5:D" & lRow).HorizontalAlignment = xlCenter
 
  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
  For i = 0 To 2
    ShName = sArr(i): TenSao = Sao(i)
    RngList.AutoFilter Field:=5, Criteria1:=TenSao
    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
        .Columns("A:E").EntireColumn.AutoFit
        .Rows("1:2").RowHeight = 21.6
      End With
      RngList.AutoFilter
    Else
      If TestSheet(ShName) Then 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
    Sh.Columns("A:E").EntireColumn.AutoFit
  End If
  Set Sh = Nothing: Set RngList = Nothing: Set Rng = Nothing
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Mình dùng font Unicode của window
Ngoài "Kế Đô" còn có sao nào dạng "K? ??" không, nếu có code sẽ gôm vào cùng 1 sao
Chỉnh dòng lệnh
Sao = Array("La H?u", "Thái B?ch", "K? ??", "Sao H?i")
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, Sao As Variant, dArr As Variant
  Dim i As Long, lRow As Long
  Dim tmp As String, ShName As String, TenSao As String
  Application.ScreenUpdating = False
  Sao = Array("La H?u", "Thái B?ch", "K? ??", "Sao H?i")
  sArr = Array("La Hau", "Thai Bach", "Ke Do", "Sao Hoi")

  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

  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
  Sh.Range("A5:E" & lRow).Borders.LineStyle = 1
  Sh.Range("A5:E" & lRow).Font.Size = 12
  Sh.Range("A5:A" & lRow).HorizontalAlignment = xlCenter
  Sh.Range("C5:D" & lRow).HorizontalAlignment = xlCenter

  Set RngList = Sh.Range("A4:E" & lRow)
  Set Rng = Sh.Range("A5:E" & lRow)
  For i = 0 To 2
    ShName = sArr(i): TenSao = Sao(i)
    RngList.AutoFilter Field:=5, Criteria1:=TenSao
    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
        .Columns("A:E").EntireColumn.AutoFit
        .Rows("1:2").RowHeight = 21.6
      End With
      RngList.AutoFilter
    Else
      If TestSheet(ShName) Then 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
    Sh.Columns("A:E").EntireColumn.AutoFit
  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ác có time không mình tải team bạn làm dùm mình he
Chưa có tên.pngChưa vdcó tên.pngChưa cdcacó tên.png
 
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