Trích Lọc dữ liệu có gộp ô

Liên hệ QC

vanaccex

Thành viên tiêu biểu
Tham gia
8/7/18
Bài viết
454
Được thích
305
Giới tính
Nữ
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!
 

File đính kèm

  • Hoi GPE.xlsx
    12.2 KB · Đọc: 13
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
 

File đính kèm

  • Hoi GPE.xlsm
    21.2 KB · Đọc: 11
Upvote 0
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 ạ !
 

File đính kèm

  • Hoi GPE.xlsm
    21.4 KB · Đọc: 10
Upvote 0
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 à.:D.
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
 
Upvote 0
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
 
Upvote 0
Dạ em vân cảm ơn anh @snow25@Ba Tê . Kết quả đã đúng ý em Vân rồi ạ !
 
Upvote 0
Web KT
Back
Top Bottom