Trích Lọc dữ liệu có gộp ô (1 người xem)

vanaccex · 14/3/19

Em Vân chào anh (chị) diễn đàn giaiphapexcel.com

Em Vân có vấn đề nhờ anh (chị) hỗ trợ.

Em Vân muốn tách sheet sheet1 Vùng dữ liệu từ A3:AX , Sang sheet Ketqua với điều kiện đồng thời là các
+ B2 (sheet Ketqua)
+ B3 (sheet Ketqua)
+ và các tháng từ ô C4:N4 (sheet Ketqua)

Em Vân cảm ơn anh (chị) nhiều!

snow25 · 14/3/19

vanaccex đã viết:
Em Vân chào anh (chị) diễn đàn giaiphapexcel.com

Em Vân có vấn đề nhờ anh (chị) hỗ trợ.

Em Vân muốn tách sheet sheet1 Vùng dữ liệu từ A3:AX , Sang sheet Ketqua với điều kiện đồng thời là các
+ B2 (sheet Ketqua)
+ B3 (sheet Ketqua)
+ và các tháng từ ô C4:N4 (sheet Ketqua)

Em Vân cảm ơn anh (chị) nhiều!

Em chạy code này xem nhé.

Mã:

Sub chuyendulieu()
    Dim arr, arr1, i As Long, j As Long, lr As Long, dic As Object, dks As String, dk As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("ketqua")
         dk = .Range("B3").Value
    End With
    With Sheet1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         arr = .Range("A3:AX" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 2)
         For i = 3 To UBound(arr, 1)
             If dk = arr(i, 1) Then
                dks = arr(i, 1) & arr(i, 2)
                If Not dic.exists(dks) Then
                   dic.Add dks, "KK"
                   a = a + 1
                   arr1(a, 1) = arr(i, 1)
                   arr1(a, 2) = arr(i, 2)
                End If
             End If
            For j = 3 To UBound(arr, 2)
                If arr(1, j) = Empty Then arr(1, j) = arr(i, j - 1)
                dks = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(2, j)
                If Not dic.exists(dks) Then
                   dic.Add dks, arr(i, j)
                Else
                   dic.Item(dks) = dic.Item(dks) + arr(i, j)
                End If
            Next j
         Next i
    End With
    With Sheets("ketqua")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("A5:N" & lr).ClearContents
         If a Then .Range("A5").Resize(a, 2).Value = arr1 Else Exit Sub
         arr = .Range("A4:N" & a + 4).Value
         For i = 2 To UBound(arr, 1)
             For j = 3 To UBound(arr, 2)
                 dk = arr(i, 1) & arr(i, 2) & arr(1, j) & .Range("b2").Value
                 If dic.exists(dk) Then
                    arr(i, j) = dic.Item(dk)
                 End If
             Next j
        Next i
        .Range("A4:N" & a + 4).Value = arr
   End With
End Sub

vanaccex · 14/3/19

snow25 đã viết:

Em chạy code này xem nhé.

Mã:

Sub chuyendulieu()
    Dim arr, arr1, i As Long, j As Long, lr As Long, dic As Object, dks As String, dk As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("ketqua")
         dk = .Range("B3").Value
    End With
    With Sheet1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         arr = .Range("A3:AX" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 2)
         For i = 3 To UBound(arr, 1)
             If dk = arr(i, 1) Then
                dks = arr(i, 1) & arr(i, 2)
                If Not dic.exists(dks) Then
                   dic.Add dks, "KK"
                   a = a + 1
                   arr1(a, 1) = arr(i, 1)
                   arr1(a, 2) = arr(i, 2)
                End If
             End If
            For j = 3 To UBound(arr, 2)
                If arr(1, j) = Empty Then arr(1, j) = arr(i, j - 1)
                dks = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(2, j)
                If Not dic.exists(dks) Then
                   dic.Add dks, arr(i, j)
                Else
                   dic.Item(dks) = dic.Item(dks) + arr(i, j)
                End If
            Next j
         Next i
    End With
    With Sheets("ketqua")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("A5:N" & lr).ClearContents
         If a Then .Range("A5").Resize(a, 2).Value = arr1 Else Exit Sub
         arr = .Range("A4:N" & a + 4).Value
         For i = 2 To UBound(arr, 1)
             For j = 3 To UBound(arr, 2)
                 dk = arr(i, 1) & arr(i, 2) & arr(1, j) & .Range("b2").Value
                 If dic.exists(dk) Then
                    arr(i, j) = dic.Item(dk)
                 End If
             Next j
        Next i
        .Range("A4:N" & a + 4).Value = arr
   End With
End Sub

Dạ em Vân cảm ơn anh ạ ! Tuy nhiên nếu Em Vân chọn Chi nhánh là B và Dữ liệu B thì kết quả hiện tại chưa được trích lọc đúng ạ !

snow25 · 16/3/19

vanaccex đã viết:
Dạ em Vân cảm ơn anh ạ ! Tuy nhiên nếu Em Vân chọn Chi nhánh là B và Dữ liệu B thì kết quả hiện tại chưa được trích lọc đúng ạ !

Em xem lại nhé.Hôm trước nhầm 1 ít chỗ điều kiện à.

.

Mã:

Sub chuyendulieu()
    Dim arr, arr1, i As Long, j As Long, lr As Long, dic As Object, dks As String, dk As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("ketqua")
         dk = .Range("B3").Value
    End With
    With Sheet1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         arr = .Range("A3:AX" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 2)
         For i = 3 To UBound(arr, 1)
             If dk = arr(i, 1) Then
                dks = arr(i, 1) & arr(i, 2)
                If Not dic.exists(dks) Then
                   dic.Add dks, "KK"
                   a = a + 1
                   arr1(a, 1) = arr(i, 1)
                   arr1(a, 2) = arr(i, 2)
                End If
             End If
            For j = 3 To UBound(arr, 2)
                If arr(1, j) = Empty Then arr(1, j) = arr(1, j - 1)
                dks = UCase(arr(i, 1) & "#" & arr(i, 2) & "#" & arr(1, j) & "#" & arr(2, j))
                If Not dic.exists(dks) Then
                   dic.Add dks, arr(i, j)
                Else
                   dic.Item(dks) = dic.Item(dks) + arr(i, j)
                End If
            Next j
         Next i
    End With
    With Sheets("ketqua")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("A5:N" & lr).ClearContents
         If a Then .Range("A5").Resize(a, 2).Value = arr1 Else Exit Sub
         arr = .Range("A4:N" & a + 4).Value
         For i = 2 To UBound(arr, 1)
             For j = 3 To UBound(arr, 2)
                 dk = UCase(arr(i, 1) & "#" & arr(i, 2) & "#" & arr(1, j) & "#" & .Range("b2").Value)
                 If dic.exists(dk) Then
                    arr(i, j) = dic.Item(dk)
                 End If
             Next j
        Next i
        .Range("A4:N" & a + 4).Value = arr
   End With
End Sub

Ba Tê · 16/3/19

vanaccex đã viết:
Dạ em Vân cảm ơn anh ạ ! Tuy nhiên nếu Em Vân chọn Chi nhánh là B và Dữ liệu B thì kết quả hiện tại chưa được trích lọc đúng ạ !

Bạn thử chạy Sub này coi sao.

PHP:

Public Sub sGpe()
Dim sArr(), dArr(), DK1 As String, DK2 As String
Dim I As Long, J As Long, N As Long, K As Long, Col As Long, R As Long
sArr = Sheet1.Range("A4", Sheet1.Range("A5").End(xlDown)).Resize(, 50).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 14)
With Sheets("Ketqua")
    DK1 = UCase(.Range("B2").Value)
    DK2 = UCase(.Range("B3").Value)
    For J = 3 To 50
        If UCase(sArr(1, J)) = DK1 Then
            N = J: Exit For
        End If
    Next J
    If N = 0 Then Exit Sub
    For I = 2 To R
        If UCase(sArr(I, 1)) = DK2 Then
            K = K + 1: Col = 2
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            For J = N To 50 Step 4
                Col = Col + 1
                dArr(K, Col) = sArr(I, J)
            Next J
        End If
    Next I
    If K Then .Range("A5").Resize(K, 14) = dArr
End With
End Sub

vanaccex · 16/3/19

Dạ em vân cảm ơn anh @snow25 và @Ba Tê . Kết quả đã đúng ý em Vân rồi ạ !

Trích Lọc dữ liệu có gộp ô (1 người xem)

Người dùng đang xem chủ đề này

vanaccex

Thành viên tiêu biểu

File đính kèm

snow25

Thành viên gạo cội

File đính kèm

vanaccex

Thành viên tiêu biểu

File đính kèm

snow25

Thành viên gạo cội

Ba Tê

Cạo Rồi Khỏi Gội

vanaccex

Thành viên tiêu biểu

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

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

Sinh nhật lần 19 GPE