Lọc sheet Data ra thành nhiều sheet theo điều kiện

LamNA · 25/6/18

Chào anh chị GPE
Nhờ anh chị hỗ trợ cách lọc dữ liệu theo điều kiện ở sheet"DK" như trong file.
Em cám ơn.

Mã:

Sub LocTest()
Dim sArr(), Arr, i As Long, j As Long, K As Long, r As Long, Col As Long, DK As Range, Cll As Range
With Sheets("DATA")
    sArr = .Range("A1", .Range("A3").End(xlDown)).Resize(, .Range("A1").End(xlToRight).Column).Value
    r = UBound(sArr)
    Arr = Sheets("A").Range("A1", Sheets("A").Range("A1").End(xlToRight)).Value
    Col = UBound(Arr, 2)
End With
ReDim dArr(1 To r, 1 To Col)
Set DK = Sheets("DK").Range("B3")
With CreateObject("Scripting.Dictionary")

    For Each Cll In DK
        If Cll <> Empty Then .Item(UCase(Cll.Value)) = ""
    Next Cll
    For i = 1 To r
        If .exists(UCase(sArr(i, 12))) Then
            K = K + 1
            For j = 1 To Col
                dArr(K, j) = sArr(i, Arr(1, j))
            Next j
       End If
    Next i
End With
Sheets("A").Range("A3").Resize(1000, Col).ClearContents
If K Then Sheets("A").Range("A3").Resize(K, Col) = dArr
Set DK = Nothing
End Sub

befaint · 25/6/18

"Lọc Điều Kiện Cho Các Sheet"
Gõ phím kiểu này chắc mỏi tay lắm nhỉ? Hoặc tay rất dẻo.

LamNA đã viết:
như trong file

.... nhưng không hiểu gì. Không lẽ ngồi tìm hiểu cái bí mật mình muốn làm gì rồi đi giúp?

Chỉ cần thấy nhiều sheets cùng cấu trúc thế kia là đã xong rồi!!!

LamNA · 26/6/18

Anh trai lúc nào cũng soi hết.
- Sheet A lọc PK
- Sheet B lọc ĐIỆN TỬ
- Sheet C lọc ĐIỆN LẠNH
- Sheet D lọc ĐIỆN GIA DỤNG
- Sheet E lọc MTB
- Sheet F lọc ĐTDĐ
- Sheet G lọc MTXT
- Sheet H lọc PK
- Sheet I lọc DV
- Sheet J lọc KHÁC
Code hiện tại em chỉ mới lọc được cho sheet A mà viết từng code thì dài nên em nhờ các anh chị hỗ trợ viết trong 1 Macro mà chạy được cho các sheet còn lại luôn

befaint · 26/6/18

LamNA đã viết:
Code hiện tại em chỉ mới lọc được cho sheet A mà viết từng code thì dài nên em nhờ các anh chị hỗ trợ viết trong 1 Macro mà chạy được cho các sheet còn lại luôn

Khúc này bài đầu không có.

Mình đi hỏi thì việc của mình là nêu câu hỏi. Nhưng câu hỏi đã nêu được đâu mà đề nghị người giúp trả lời?

LamNA đã viết:
Anh trai lúc nào cũng soi hết.

Mình cần được giúp đỡ thì thể hiện sự cầu thị, ở đâu cũng vậy mà. (Nhưng nếu mình có tiền và có quyền thì 'chắc' không cần.)
Và kết quả cuối cùng là vẫn vậy, chưa nêu được câu hỏi.!!!

(Viết lại). Mẫu đăng bài hỏi:
- Cho: cái gì, ở đâu (sheet, vùng, ô nào)?
- Hỏi: Cần làm gì, điều kiện với cái CHO như nào?
- Kết quả: Để ở đâu, minh họa (vài trường hợp, lưu ý các trường hợp đặc biệt của kết quả).

be_09 · 26/6/18

LamNA đã viết:
Anh trai lúc nào cũng soi hết.
- Sheet A lọc PK
- Sheet B lọc ĐIỆN TỬ
- Sheet C lọc ĐIỆN LẠNH
- Sheet D lọc ĐIỆN GIA DỤNG
- Sheet E lọc MTB
- Sheet F lọc ĐTDĐ
- Sheet G lọc MTXT
- Sheet H lọc PK
- Sheet I lọc DV
- Sheet J lọc KHÁC
Code hiện tại em chỉ mới lọc được cho sheet A mà viết từng code thì dài nên em nhờ các anh chị hỗ trợ viết trong 1 Macro mà chạy được cho các sheet còn lại luôn

Góp ý:
1/ Với nội dung này, người ta gọi là tách sheet, chứ không ai gọi là lọc.
2/ Tiêu đề bài viết chưa được cụ thể, nên sừa lại là "Dựa vào cột K của sheet DATA, tách mỗi sheet là 1 loại hàng", chỉ đơn giản vậy thôi mà diễn giải lòng vòng quá.
3/ Khi tách sheet người ta dùng loại hàng là điều kiện để đặt tên cho mỗi sheet luôn, chứ không ai đưa điều kiện tên sheet là A, B, C như nêu ở sheet DK. Diễn giải đã không rõ ràng rồi mà còn đưa thêm cái vụ A, B, C nữa thì còn rối hơn canh hẹ.

gttrongvn · 26/6/18

mình chỉnh sửa một số chỗ code trong file của bạn, bạn tham khảo nha.

Mã:

Sub LocTest()
Dim sArr(), Arr
Dim i, j, K, r, Col, sht, lr As Long
Dim DK, shtname As String
With Sheets("DATA")
      sArr = .Range("A1", .Range("A3").End(xlDown)).Resize(, .Range("A1").End(xlToRight).Column).Value
      r = UBound(sArr)
      Arr = Sheets("A").Range("A1", Sheets("A").Range("A1").End(xlToRight)).Value
      Col = UBound(Arr, 2)
End With
lr = Sheets("DK").Cells(Rows.Count, "A").End(xlUp).Row
For sht = 3 To lr
      ReDim dArr(1 To r, 1 To Col)
      shtname = Sheets("DK").Range("A" & sht)
      DK = Sheets("DK").Range("B" & sht)
      If Len(DK) > 0 Then
            K = 0
            For i = 1 To r
                  If sArr(i, 12) = DK Then
                        K = K + 1
                        For j = 1 To Col
                              dArr(K, j) = sArr(i, Arr(1, j))
                        Next j
                  End If
            Next i
      End If
      Sheets(shtname).Range("A3").Resize(100000, Col).ClearContents
      If K Then Sheets(shtname).Range("A3").Resize(K, Col) = dArr
Next sht
End Sub

LamNA · 26/6/18

gttrongvn đã viết:

mình chỉnh sửa một số chỗ code trong file của bạn, bạn tham khảo nha.

Mã:

Sub LocTest()
Dim sArr(), Arr
Dim i, j, K, r, Col, sht, lr As Long
Dim DK, shtname As String
With Sheets("DATA")
      sArr = .Range("A1", .Range("A3").End(xlDown)).Resize(, .Range("A1").End(xlToRight).Column).Value
      r = UBound(sArr)
      Arr = Sheets("A").Range("A1", Sheets("A").Range("A1").End(xlToRight)).Value
      Col = UBound(Arr, 2)
End With
lr = Sheets("DK").Cells(Rows.Count, "A").End(xlUp).Row
For sht = 3 To lr
      ReDim dArr(1 To r, 1 To Col)
      shtname = Sheets("DK").Range("A" & sht)
      DK = Sheets("DK").Range("B" & sht)
      If Len(DK) > 0 Then
            K = 0
            For i = 1 To r
                  If sArr(i, 12) = DK Then
                        K = K + 1
                        For j = 1 To Col
                              dArr(K, j) = sArr(i, Arr(1, j))
                        Next j
                  End If
            Next i
      End If
      Sheets(shtname).Range("A3").Resize(100000, Col).ClearContents
      If K Then Sheets(shtname).Range("A3").Resize(K, Col) = dArr
Next sht
End Sub

Cám ơn gttrongvn đã hỗ trợ

ndu96081631 · 26/6/18

LamNA đã viết:

Chào anh chị GPE
Nhờ anh chị hỗ trợ cách lọc dữ liệu theo điều kiện ở sheet"DK" như trong file.
Em cám ơn.

Mã:

Sub LocTest()
Dim sArr(), Arr, i As Long, j As Long, K As Long, r As Long, Col As Long, DK As Range, Cll As Range
With Sheets("DATA")
    sArr = .Range("A1", .Range("A3").End(xlDown)).Resize(, .Range("A1").End(xlToRight).Column).Value
    r = UBound(sArr)
    Arr = Sheets("A").Range("A1", Sheets("A").Range("A1").End(xlToRight)).Value
    Col = UBound(Arr, 2)
End With
ReDim dArr(1 To r, 1 To Col)
Set DK = Sheets("DK").Range("B3")
With CreateObject("Scripting.Dictionary")

    For Each Cll In DK
        If Cll <> Empty Then .Item(UCase(Cll.Value)) = ""
    Next Cll
    For i = 1 To r
        If .exists(UCase(sArr(i, 12))) Then
            K = K + 1
            For j = 1 To Col
                dArr(K, j) = sArr(i, Arr(1, j))
            Next j
       End If
    Next i
End With
Sheets("A").Range("A3").Resize(1000, Col).ClearContents
If K Then Sheets("A").Range("A3").Resize(K, Col) = dArr
Set DK = Nothing
End Sub

Bài này dùng Advanced Filter là nhanh nhất (chỉ với 1 vòng lập). Cách làm như sau:
1> Tại sheet "DK", quét chọn khu vực A2:B12, tạo table và đặt tên cho table là tbCriteria

2> Code dùng Advanced Filter:

Mã:

Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Sheets(SheetName) Is Nothing
End Function
Sub CreateReport()
  Dim rngCriteria As Range, rngSource As Range, cel As Range
  Dim strSheetName As String, strCriteria As String
  Set rngCriteria = Sheets("DK").Range("IV1:IV2")
  Set rngSource = Sheets("DATA").Range("A2", Sheets("DATA").Range("M60000").End(xlUp))
  rngCriteria(1, 1) = "NH"
  For Each cel In Range("tbCriteria[Ngành Hàng]")
    strSheetName = cel.Offset(, -1).Value
    strCriteria = cel.Value
    If SheetExists(strSheetName) Then
      rngCriteria(2, 1) = strCriteria
      Sheets(strSheetName).UsedRange.Clear
      rngSource.AdvancedFilter 2, rngCriteria, Sheets(strSheetName).Range("A2")
    End If
  Next
End Sub

Xong!

LamNA · 26/6/18

ndu96081631 đã viết:
Bài này dùng Advanced Filter là nhanh nhất (chỉ với 1 vòng lập). Cách làm như sau:
1> Tại sheet "DK", quét chọn khu vực A2:B12, tạo table và đặt tên cho table là tbCriteria

View attachment 198164

2> Code dùng Advanced Filter:

Mã:

Function SheetExists(ByVal SheetName As String) As Boolean On Error Resume Next SheetExists = Not Sheets(SheetName) Is Nothing End Function Sub CreateReport() Dim rngCriteria As Range, rngSource As Range, cel As Range Dim strSheetName As String, strCriteria As String Set rngCriteria = Sheets("DK").Range("IV1:IV2") Set rngSource = Sheets("DATA").Range("A2", Sheets("DATA").Range("M60000").End(xlUp)) rngCriteria(1, 1) = "NH" For Each cel In Range("tbCriteria[Ngành Hàng]") strSheetName = cel.Offset(, -1).Value strCriteria = cel.Value If SheetExists(strSheetName) Then rngCriteria(2, 1) = strCriteria Sheets(strSheetName).UsedRange.Clear rngSource.AdvancedFilter 2, rngCriteria, Sheets(strSheetName).Range("A2") End If Next End Sub

Xong!

Em cám ơn thầy

Lọc sheet Data ra thành nhiều sheet theo điều kiện

LamNA

Thành viên tích cực

File đính kèm

befaint

|||||||||||||

LamNA

Thành viên tích cực

befaint

|||||||||||||

be_09

Biên Hòa, Đồng Nai

gttrongvn

Thành viên hoạt động

LamNA

Thành viên tích cực

ndu96081631

Huyền thoại GPE

File đính kèm

LamNA

Thành viên tích cực

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

Facebook

Group

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