LỌC DỮ LIỆU TỪ NHIỀU SHEET VÀ COPY VỀ 1 SHEET (3 người xem)

[linhthusinh]

Kính gửi các anh chị trong diễn đàn!
Em có 1 file excel muốn nhờ các anh chị giúp đỡ như sau:
Em muốn lọc các hồ sơ trong các sheet từ sheet 1 đến sheet 4. Điều kiện lọc là tình trạng hồ sơ "Chưa có" (Cột Tình trạng).
Sau đó tổng hợp danh mục các hồ sơ chưa có về sheet "HS CON THIEU". Em mong muốn kết quả như sheet "HS CON THIEU" mà em đang làm thủ công.
Em đang lọc và copy thủ công, nhiều sheet thì không khả thi nên nhờ anh/chị trên diễn đàn giúp em với.
Anh/chị xem file để hiểu rõ hơn câu hỏi ạ!
Trân trọng và cảm ơn!

 

[anhtuan2939]

Kính gửi các anh chị trong diễn đàn!
Em có 1 file excel muốn nhờ các anh chị giúp đỡ như sau:
Em muốn lọc các hồ sơ trong các sheet từ sheet 1 đến sheet 4. Điều kiện lọc là tình trạng hồ sơ "Chưa có" (Cột Tình trạng).
Sau đó tổng hợp danh mục các hồ sơ chưa có về sheet "HS CON THIEU". Em mong muốn kết quả như sheet "HS CON THIEU" mà em đang làm thủ công.
Em đang lọc và copy thủ công, nhiều sheet thì không khả thi nên nhờ anh/chị trên diễn đàn giúp em với.
Anh/chị xem file để hiểu rõ hơn câu hỏi ạ!
Trân trọng và cảm ơn!

Bạn chạy thử code này xem, code hơi luộm thuộm tí nhưng bạn dễ hình dung hơn

Sub Loc()
    Dim k%, lr%, lst%, Row%
    Dim sh As Worksheet
    
    Application.ScreenUpdating = False
    
    Sheets("HS CON THIEU").Rows(7 & ":" & 1000).Delete
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HS CON THIEU" Then
            With sh
                If .AutoFilterMode = True Then .AutoFilterMode = False
                lr = .Range("B" & Rows.Count).End(xlUp).Row
                lst = Sheets("HS CON THIEU").Range("B" & Rows.Count).End(xlUp).Row + 1
                lst = IIf(lst < 7, lst + 1, lst)
                .Range("A7:H" & lr).AutoFilter Field:=6, Criteria1:="Ch?a có"
                Row = .Range("B" & Rows.Count).End(xlUp).Row
                If Row >= 7 Then .Range("A7:H" & lr).Copy Sheets("HS CON THIEU").Range("A" & lst)
                .AutoFilterMode = False
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[linhthusinh]

Bạn chạy thử code này xem, code hơi luộm thuộm tí nhưng bạn dễ hình dung hơn

Sub Loc()
    Dim k%, lr%, lst%, Row%
    Dim sh As Worksheet
   
    Application.ScreenUpdating = False
   
    Sheets("HS CON THIEU").Rows(7 & ":" & 1000).Delete
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HS CON THIEU" Then
            With sh
                If .AutoFilterMode = True Then .AutoFilterMode = False
                lr = .Range("B" & Rows.Count).End(xlUp).Row
                lst = Sheets("HS CON THIEU").Range("B" & Rows.Count).End(xlUp).Row + 1
                lst = IIf(lst < 7, lst + 1, lst)
                .Range("A7:H" & lr).AutoFilter Field:=6, Criteria1:="Ch?a có"
                Row = .Range("B" & Rows.Count).End(xlUp).Row
                If Row >= 7 Then .Range("A7:H" & lr).Copy Sheets("HS CON THIEU").Range("A" & lst)
                .AutoFilterMode = False
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Dạ em cảm ơn anh ạ! Em chạy thử rồi báo lại anh.

 

[snow25]

Kính gửi các anh chị trong diễn đàn!
Em có 1 file excel muốn nhờ các anh chị giúp đỡ như sau:
Em muốn lọc các hồ sơ trong các sheet từ sheet 1 đến sheet 4. Điều kiện lọc là tình trạng hồ sơ "Chưa có" (Cột Tình trạng).
Sau đó tổng hợp danh mục các hồ sơ chưa có về sheet "HS CON THIEU". Em mong muốn kết quả như sheet "HS CON THIEU" mà em đang làm thủ công.
Em đang lọc và copy thủ công, nhiều sheet thì không khả thi nên nhờ anh/chị trên diễn đàn giúp em với.
Anh/chị xem file để hiểu rõ hơn câu hỏi ạ!
Trân trọng và cảm ơn!

Thử code này.

Sub abc()
    Dim i As Long, lr As Long, sh As Worksheet, kq(1 To 1000, 1 To 8), dk As String, b As Boolean, arr, a As Long, j As Integer
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HS CON THIEU" Then
           b = False
           With sh
                lr = .Range("B" & Rows.Count).End(xlUp).Row
                arr = .Range("A8:H" & lr).Value
                dk = .Range("A7").Value
                For i = 1 To UBound(arr)
                    If arr(i, 6) = "Ch" & ChrW(432) & "a có" Then
                       If b = False Then
                          a = a + 1
                          kq(a, 1) = dk
                          b = True
                       End If
                       a = a + 1
                       For j = 1 To 8
                           kq(a, j) = arr(i, j)
                       Next j
                    End If
                Next i
          End With
      End If
  Next
  With Sheets("HS CON THIEU")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 6 Then .Range("A7:H" & lr).ClearContents
       If a Then .Range("A7:H7").Resize(a).Value = kq
  End With
End Sub

 

[linhthusinh]

Thử code này.

Sub abc()
    Dim i As Long, lr As Long, sh As Worksheet, kq(1 To 1000, 1 To 8), dk As String, b As Boolean, arr, a As Long, j As Integer
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HS CON THIEU" Then
           b = False
           With sh
                lr = .Range("B" & Rows.Count).End(xlUp).Row
                arr = .Range("A8:H" & lr).Value
                dk = .Range("A7").Value
                For i = 1 To UBound(arr)
                    If arr(i, 6) = "Ch" & ChrW(432) & "a có" Then
                       If b = False Then
                          a = a + 1
                          kq(a, 1) = dk
                          b = True
                       End If
                       a = a + 1
                       For j = 1 To 8
                           kq(a, j) = arr(i, j)
                       Next j
                    End If
                Next i
          End With
      End If
  Next
  With Sheets("HS CON THIEU")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 6 Then .Range("A7:H" & lr).ClearContents
       If a Then .Range("A7:H7").Resize(a).Value = kq
  End With
End Sub

Dạ em cảm ơn a rất nhiều! Code em chạy được rồi ạ!

Bài đã được tự động gộp: 7/12/22

Bạn chạy thử code này xem, code hơi luộm thuộm tí nhưng bạn dễ hình dung hơn

Sub Loc()
    Dim k%, lr%, lst%, Row%
    Dim sh As Worksheet
   
    Application.ScreenUpdating = False
   
    Sheets("HS CON THIEU").Rows(7 & ":" & 1000).Delete
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HS CON THIEU" Then
            With sh
                If .AutoFilterMode = True Then .AutoFilterMode = False
                lr = .Range("B" & Rows.Count).End(xlUp).Row
                lst = Sheets("HS CON THIEU").Range("B" & Rows.Count).End(xlUp).Row + 1
                lst = IIf(lst < 7, lst + 1, lst)
                .Range("A7:H" & lr).AutoFilter Field:=6, Criteria1:="Ch?a có"
                Row = .Range("B" & Rows.Count).End(xlUp).Row
                If Row >= 7 Then .Range("A7:H" & lr).Copy Sheets("HS CON THIEU").Range("A" & lst)
                .AutoFilterMode = False
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Dạ em chạy code được rồi ạ! Code của a và a Snow25 e dùng đều ok. Một lần nữa xin cảm ơn 2 anh!