So sánh và tổng hợp dữ liệu

[Hoacomay96]

Em xin cảm ơn bác Sa_DQ đã giành thời gian làm giúp em, em biết bác rất bận nên ngại không giám làm phiền bác. Bác có thể chỉnh giúp em chút xíu nữa được không ạ ? em muốn chuyển tên cột ra riêng 1 cột khác, và cột thứ 2 là số thứ tự của dòng dữ liệu. Em có file mẫu kèm theo, nhờ bác xem giúp.

 

[SA_DQ]

Quá iêu cầu nữa là đằng khác

Option Explicit

Sub SoSanhDuLieu()
 Dim lRow As Long, cRow As Long, dRow As Long, jJ As Long
 Dim jW As Long, jZ As Long:                Dim iJ As Integer
 Dim Rng As Range, RngC As Range:           Dim sCot As String
 
 Application.ScreenUpdating = False
 lRow = [c65432].End(xlUp).Row:             Range("A38:R321").Clear ''
 Range("F2:O2").Copy Destination:=Range("F38")
 [A38] = "Ten cot":                         [b38] = "So TT"
 [c38] = "Dong-Cot"
 Range("A38:O38").Select:                   Selection.Font.Bold = True

 For jW = 18 To 23
    cRow = Range(Chr(64 + jW) & 36).End(xlUp).Row
    If cRow = 1 Then GoTo 17
    For jJ = 3 To lRow
        For jZ = 2 To cRow
            If Cells(jJ, 3) = Cells(jZ, jW) Then
                If Rng Is Nothing And RngC Is Nothing Then
                    sCot = Cells(jZ - 1, jW)  ''
                    Set Rng = Cells(jZ, jW)  'Cot i'
                    Set RngC = Cells(jJ, 3).Resize(1, 13)
                Else
                    Set Rng = Union(Rng, Cells(jZ, jW))
                    Set RngC = Union(RngC, Cells(jJ, 3).Resize(1, 13))
                End If
            End If
        Next jZ
    Next jJ
    dRow = [F65432].End(xlUp).Row + 1
    If dRow > 39 Then dRow = dRow + 1:
    Rng.Copy Destination:=Range("B" & dRow):        Range("A" & dRow) = sCot
    RngC.Copy Destination:=Range("C" & dRow)
    Set Rng = Nothing:                      Set RngC = Nothing
17 Next jW
 lRow = [c65432].End(xlUp).Row + 1:         dRow = 39
 For jW = 39 To lRow
    If Cells(jW, 4) = "" Then
        Cells(jW, 2) = "Tong " & Right(Range("A" & Cells(jW, 1).End(xlUp).Row), 2)
        Range("B" & jW & ":C" & jW).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
        End With
        Selection.Merge
        cRow = jW - 1
        Cells(jW, 4).Formula = "=SUM(D" & dRow & ":D" & cRow & ")"
        Range("D" & jW).AutoFill Destination:=Range("D" & jW & _
            ":O" & jW), Type:=xlFillDefault

        dRow = jW + 1
    End If
 Next jW
 Range("A39:A" & lRow).Select:               Selection.Font.Bold = True
 
End Sub

 

[Hoacomay96]

Xin lỗi bác Sa_DQ nhé, em đã làm phiền bác nhiều quá mong bác thông cảm cho.Em không thạo VBA mà bác lại là 1 cao thủ ...hi hi..

Bác Sa_DQ ơi sao các dòng tổng có hàm Sum thì rất đúng mà kết quả lại tính sai là do sao bác nhỉ ?

Do bị nhầm lẫn thôi. Xin lỗi bác Sa_DQ code vẫn hạy tốt. Em cảm ơn bác nhiều. Bac chỉnh lại giúp em với: cột thứ 2 (số TT) trong bảng kết quả chạy ra phải là số thứ tự liên tục từ 1 đến hết, khác cột thứ 3 .

Em cảm ơn bác Sa_DQ đã giúp em tận tình. code đã chạy tốt như ý muốn.

To HoaCoMay: Chỉ cần ấn vô nút 'Cảm ơn' là đủ rồi

 

[SA_DQ]

Muốn có số thứ tự thì có số thứ tự!

Sub SoSanhDuLieu()
 Dim lRow As Long, cRow As Long, dRow As Long, jJ As Long
 Dim jW As Long, jZ As Long:                Dim iJ As Integer
 Dim Rng As Range, RngC As Range:           Dim sCot As String
 
 Application.ScreenUpdating = False
 lRow = [c65432].End(xlUp).Row:             Range("A38:R321").Clear ''
 Range("F2:O2").Copy Destination:=Range("F38")
 [A38] = "Ten cot":                         [b38] = "So TT"
 [c38] = "Dong-Cot"
 Range("A38:O38").Select:                   Selection.Font.Bold = True

 For jW = 18 To 23
    cRow = Range(Chr(64 + jW) & 36).End(xlUp).Row
    If cRow = 1 Then GoTo 17
    For jJ = 3 To lRow
        For jZ = 2 To cRow
            If Cells(jJ, 3) = Cells(jZ, jW) Then
                If Rng Is Nothing And RngC Is Nothing Then
                    sCot = Cells(jZ - 1, jW)  ''
                    Set RngC = Cells(jJ, 3).Resize(1, 13)
                Else
                    Set RngC = Union(RngC, Cells(jJ, 3).Resize(1, 13))
                End If
            End If
        Next jZ
    Next jJ
    dRow = [F65432].End(xlUp).Row + 1
    If dRow > 39 Then dRow = dRow + 1:              jJ = 1
    RngC.Copy Destination:=Range("C" & dRow):        Range("A" & dRow) = sCot
    Set Rng = Nothing:                      Set RngC = Nothing
17 Next jW
 lRow = [c65432].End(xlUp).Row + 1:                 dRow = 39
 For jW = 39 To lRow
    If Cells(jW, 4) = "" Then
        Cells(jW, 2) = "Tong " & Right(Range("A" & Cells(jW, 1).End(xlUp).Row), 2)
        Range("B" & jW & ":C" & jW).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter:            .Font.Bold = True
        End With
        Selection.Merge
        cRow = jW - 1
        Cells(jW, 4).Formula = "=SUM(D" & dRow & ":D" & cRow & ")"
        Range("D" & jW).AutoFill Destination:=Range("D" & jW & _
            ":O" & jW), Type:=xlFillDefault
        dRow = jW + 1
    Else
        Cells(jW, 2) = "'" & Right("0" & CStr(jJ), 2):  jJ = jJ + 1
    End If
 Next jW
 Range("A39:A" & lRow).Select:               Selection.Font.Bold = True
 
End Sub