LỌC DỮ LIỆU TỪ NHIỀU SHEET VÀ COPY VỀ 1 SHEET

Chia sẻ bởi:hands

★★★★★

‹ Nhờ sửa code tính tổng khi gộp... Code copy sang cột kế tiếp mỗi... ›

Quảng cáo

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

www.giaiphapexcel.com/diendan/threads/l%E1%BB%8Cc-d%E1%BB%AE-li%E1%BB%86u-t%E1%BB%AA-nhi%E1%BB%80u-sheet-v%C3%80-copy-v%E1%BB%80-1-sheet.163362/post-1089712

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

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

www.giaiphapexcel.com/diendan/threads/l%E1%BB%8Cc-d%E1%BB%AE-li%E1%BB%86u-t%E1%BB%AA-nhi%E1%BB%80u-sheet-v%C3%80-copy-v%E1%BB%80-1-sheet.163362/post-1089726