Gộp phần công việc và chi tiết vào cùng 1 cột

[axa00000019]

Nhờ các anh chị giúp đỡ code VBA gộp phần công việc và chi tiết vào cùng 1 cột. Cảm ơn cả nhà rất nhiều ạ!

 

[anhtuan2939]

Nhờ các anh chị giúp đỡ code VBA gộp phần công việc và chi tiết vào cùng 1 cột. Cảm ơn cả nhà rất nhiều ạ!

Bạn thử code này xem

Sub Tong_hop()
    Dim dict As Object, sArr(), dArr()
    Dim i&, lr&, R&
    Dim tmp$
    
    Application.ScreenUpdating = False
    
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("J2:L1000").ClearContents
        .Range("J2:J1000").Font.ColorIndex = xlNone
        .Range("J2:J1000").Font.Bold = False
        sArr = .Range("A2:F" & lr).Value
        ReDim dArr(1 To 1000, 1 To 3)
        For i = 1 To UBound(sArr)
            tmp = sArr(i, 1) & " - " & Format(sArr(i, 2), "DD/MM/YYYY") & " - " & sArr(i, 3)
            If Not dict.Exists(tmp) Then
                R = R + 1
                dict.Add tmp, R
                dArr(R, 1) = tmp
                .Range("J" & R + 1).Font.ColorIndex = 3
                .Range("J" & R + 1).Font.Bold = True
            End If
            R = R + 1
            dArr(R, 1) = sArr(i, 4)
            dArr(R, 2) = sArr(i, 5)
            dArr(R, 3) = sArr(i, 6)
        Next i
        
        .Range("J2").Resize(R, 3).Value = dArr
    End With
    
    Set dict = Nothing
    Application.ScreenUpdating = True
End Sub

 

[axa00000019]

Bạn thử code này xem

Sub Tong_hop()
    Dim dict As Object, sArr(), dArr()
    Dim i&, lr&, R&
    Dim tmp$
   
    Application.ScreenUpdating = False
   
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
   
    With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("J2:L1000").ClearContents
        .Range("J2:J1000").Font.ColorIndex = xlNone
        .Range("J2:J1000").Font.Bold = False
        sArr = .Range("A2:F" & lr).Value
        ReDim dArr(1 To 1000, 1 To 3)
        For i = 1 To UBound(sArr)
            tmp = sArr(i, 1) & " - " & Format(sArr(i, 2), "DD/MM/YYYY") & " - " & sArr(i, 3)
            If Not dict.Exists(tmp) Then
                R = R + 1
                dict.Add tmp, R
                dArr(R, 1) = tmp
                .Range("J" & R + 1).Font.ColorIndex = 3
                .Range("J" & R + 1).Font.Bold = True
            End If
            R = R + 1
            dArr(R, 1) = sArr(i, 4)
            dArr(R, 2) = sArr(i, 5)
            dArr(R, 3) = sArr(i, 6)
        Next i
       
        .Range("J2").Resize(R, 3).Value = dArr
    End With
   
    Set dict = Nothing
    Application.ScreenUpdating = True
End Sub

Code rất đúng ý Em. Xin cảm ơn anhtuan2939 rất nhiều ạ!