Tìm lỗi trong code lọc dữ liệu

[ditimdl]

Chào các bạn!

Mình có 1 file dùng advanced filter để lọc dữ liệu (Code lúc trước bác NDU viết cho mình), trước giờ vẫn hoạt động tốt nhưng gần đây có thay đổi 1 tý điều kiệu lọc nên mình có edit lại. Sau khi edit thì mỗi lần chạy code nó cứ báo lỗi Runtime '1004 hoài. Điều kiện lọc tồn tại, dữ liệu lọc có đấy nhưng nó không thể lọc được. Mình gửi file đính kèm theo bài viết, mong các bác rãnh rỗi tạo điều kiện tìm hiểu xem nó sai ở đâu dùm mình.

Private Sub Adv_filter_Click()
Dim Rng As Range, Temp As Range, Sh As Worksheet, i As Long, ShName
  Application.ScreenUpdating = False
  i = 6
  ShName = Array("AV", "BV", "CV", "DV", "EL", "GL", "HL", "JL", "T1", "T2", "T3", "T4", "TE")
  For Each Sh In ThisWorkbook.Worksheets
    DK = Application.HLookup(Sh.Name, ShName, 1, 0)
    If Not IsError(DK) Then
       Sh.Range("A5").CurrentRegion.EntireRow.Delete
       With Sheets("TOTAL")
          Set Rng = .[A5].CurrentRegion
          .[Q6:Q20].ClearContents
          Select Case Sh.Name
            Case Is = "TE": .[Q6] = Sh.Name
            Case Is = "AV": .[Q6] = "AV": .[Q7] = "CH": .[Q8] = "HC": .[Q9] = "CA"
            Case Is = "BV": .[Q6] = "BV": .[Q7] = "B1": .[Q8] = "B2": .[Q9] = "DN"
            Case Is = "CV": .[Q6] = "CV": .[Q7] = "H3": .[Q8] = "HX": .[Q9] = "XV"
            Case Is = "DV": .[Q6] = "DV": .[Q7] = "H1": .[Q8] = "D1": .[Q9] = "D2": .[Q10] = "HD": .[Q11] = "JQ": .[Q12] = "TA": .[Q13] = "TY"
            Case Is = "EL": .[Q6] = "EL": .[Q7] = "ES": .[Q8] = "CC": .[Q9] = "CK": .[Q10] = "CB": .[Q11] = "KC": .[Q12] = "JC"
            Case Is = "GL": .[Q6] = "FL": .[Q7] = "GL": .[Q8] = "IS": .[Q9] = "IL": .[Q10] = "BT"
            Case Is = "HL": .[Q6] = "HL": .[Q7] = "IA": .[Q8] = "IB": .[Q9] = "HT": .[Q10] = "JB": .[Q11] = "MS": .[Q12] = "XB": .[Q13] = "XN": .[Q14] = "JY"
            Case Is = "JL": .[Q6] = "JL": .[Q7] = "HN": .[Q8] = "CN"
            Case Is = "T1": .[Q6] = "T1": .[Q7] = "TC": .[Q8] = "GD": .[Q9] = "TX"
            Case Is = "T2": .[Q6] = "T2": .[Q7] = "UC": .[Q8] = "HS"
            Case Is = "T3": .[Q6] = "T3": .[Q7] = "XK"
            Case Is = "T4": .[Q6] = "XV": .[Q7] = "TL"
          End Select
          Rng.AdvancedFilter Action:=1, CriteriaRange:=.[Q5].CurrentRegion
          Rng.SpecialCells(xlCellTypeVisible).Copy Destination:=.[A20000]
       End With
       With Sheets("TOTAL").[A20000].CurrentRegion
          .Copy: Sh.[A5].Insert Shift:=xlDown
          .ClearContents: .ClearFormats
       End With
       Set Temp = Sh.[A5].CurrentRegion
       Temp.Offset(Temp.Rows.Count + 1, 2).Resize(1, 13).SpecialCells(3, 23).Copy
       Sheets("TONGHOP").Cells(i, 3).PasteSpecial xlPasteValues
       'Doan nay sau khi loc se danh lai so thu tu tu 1
       'If Temp.Rows.Count > 1 Then
          'With Temp.Offset(1, 0).Resize(Temp.Rows.Count - 1, 1)
             '.Formula = "=ROW() -5"
             '.Value = .Value
          'End With
       'End If
       'Ket thuc dong lenh
       Sheets("TOTAL").ShowAllData
       i = i + 1
     End If
   Next Sh
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   ActiveWorkbook.Save
   End Sub

Cảm ơn các bác nhiều!
Chúc sức khỏe đến toàn thể anh em GPE!

 

[SA_DQ]

Lỗi sẩy ra do không có dữ liệu trong các trang tính

Bạn hãy thử với macro được bổ sung bẩy lỗi sau:

Private Sub Adv_filter_Click()
 On Error GoTo Loi
Dim Rng As Range, Temp As Range, Sh As Worksheet, i As Long, ShName
  Application.ScreenUpdating = False
  i = 6
  ShName = Array("AV", "BV", "CV", "DV", "EL", "GL", "HL", "JL", "T1", "T2", "T3", "T4", "TE")
  For Each Sh In ThisWorkbook.Worksheets
    DK = Application.HLookup(Sh.Name, ShName, 1, 0)
    If Not IsError(DK) Then
       Sh.Range("A5").CurrentRegion.EntireRow.Delete
       With Sheets("TOTAL")
          Set Rng = .[A5].CurrentRegion
          .[Q6:Q20].ClearContents
          Select Case Sh.Name
            Case Is = "TE": .[Q6] = Sh.Name
            Case Is = "AV": .[Q6] = "AV": .[Q7] = "CH": .[Q8] = "HC": .[Q9] = "CA"
            Case Is = "BV": .[Q6] = "BV": .[Q7] = "B1": .[Q8] = "B2": .[Q9] = "DN"
            Case Is = "CV": .[Q6] = "CV": .[Q7] = "H3": .[Q8] = "HX": .[Q9] = "XV"
            Case Is = "DV": .[Q6] = "DV": .[Q7] = "H1": .[Q8] = "D1": .[Q9] = "D2":
               .[Q10] = "HD": .[Q11] = "JQ": .[Q12] = "TA": .[Q13] = "TY"
            Case Is = "EL": .[Q6] = "EL": .[Q7] = "ES": .[Q8] = "CC": .[Q9] = "CK":
               .[Q10] = "CB": .[Q11] = "KC": .[Q12] = "JC"
            Case Is = "GL": .[Q6] = "FL": .[Q7] = "GL": .[Q8] = "IS": .[Q9] = "IL":
               .[Q10] = "BT"
            Case Is = "HL": .[Q6] = "HL": .[Q7] = "IA": .[Q8] = "IB": .[Q9] = "HT":
               .[Q10] = "JB": .[Q11] = "MS": .[Q12] = "XB": .[Q13] = "XN": .[Q14] = "JY"
            Case Is = "JL": .[Q6] = "JL": .[Q7] = "HN": .[Q8] = "CN"
            Case Is = "T1": .[Q6] = "T1": .[Q7] = "TC": .[Q8] = "GD": .[Q9] = "TX"
            Case Is = "T2": .[Q6] = "T2": .[Q7] = "UC": .[Q8] = "HS"
            Case Is = "T3": .[Q6] = "T3": .[Q7] = "XK"
            Case Is = "T4": .[Q6] = "XV": .[Q7] = "TL"
          End Select
          Rng.AdvancedFilter Action:=1, CriteriaRange:=.[Q5].CurrentRegion
          Rng.SpecialCells(xlCellTypeVisible).Copy Destination:=.[A20000]
       End With
       With Sheets("TOTAL").[A20000].CurrentRegion
          .Copy: Sh.[A5].Insert Shift:=xlDown
          .ClearContents: .ClearFormats
       End With
1       Set Temp = Sh.[A5].CurrentRegion
13       Temp.Offset(Temp.Rows.Count + 1, 2).Resize(1, 13).SpecialCells(3, 23).Copy
9       Sheets("TONGHOP").Cells(i, 3).PasteSpecial xlPasteValues
       Sheets("TOTAL").ShowAllData
       i = i + 1
     End If
   Next Sh
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   ActiveWorkbook.Save
   Exit Sub
Loi:
   MsgBox Sh.Name
   If Err = 1004 Then Resume Next
End Sub

 

[ditimdl]

Vô lý nhỉ? Trước giờ nó chỉ có cái mẫu như vậy, khi lọc rồi copy sang nó insert xuống thôi. Chỉ có rename tên sheet với 1 số điều kiện lọc mà giờ nó báo thế này thì ngồi nhìn thôi.