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

vanaccex

Thành viên thường trực
Tham gia ngày
8 Tháng bảy 2018
Bài viết
247
Được thích
67
Điểm
45
Tuổi
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!
 

File đính kèm

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,581
Được thích
1,274
Điểm
210
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

vanaccex

Thành viên thường trực
Tham gia ngày
8 Tháng bảy 2018
Bài viết
247
Được thích
67
Điểm
45
Tuổi
19
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

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,581
Được thích
1,274
Điểm
210
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
 

Ba Tê

Cạo Rồi Sẽ Gội
Tham gia ngày
5 Tháng năm 2009
Bài viết
10,743
Được thích
15,148
Điểm
1,860
Tuổi
60
Nơi ở
An Giang
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

Thành viên thường trực
Tham gia ngày
8 Tháng bảy 2018
Bài viết
247
Được thích
67
Điểm
45
Tuổi
19
Dạ em vân cảm ơn anh @snow25@Ba Tê . Kết quả đã đúng ý em Vân rồi ạ !
 
Top