Xin giúp về Merge Cell - Thay đổi cấu trúc bảng dữ liệu

[Hello World Cup]

Xin chào GPE!

Hiện tại mình cần chuyển đổi cấu trúc bảng dữ liệu ban đầu - sheet GOC - sang bảng dữ liệu kiểu khác - sheet KQ- kèm thêm một vài định dạng.

Rất mong các bạn giúp mình.
Chúc các bạn một ngày tốt lành.

 

[SA_DQ]

Đây là phần cốt lõi của macro mà bạn cần:

Sub GopDuLieu()
 Dim Rws As Long, Col As Integer, STT As Integer, W As Integer, J As Long
 Dim Arr():                             Dim Nhom As String
 
 Sheets("KQ").Select:                   Rws = Sheets("KQ").UsedRange.Rows.Count
 Range("A2:G" & Rws).Delete
 With Sheets("Goc")
    Rws = .UsedRange.Rows.Count:        Col = .UsedRange.Columns.Count
    ReDim Arr(1 To 2 * Rws, 1 To Col)
    For J = 2 To Rws
        If .Cells(J, "H").Value <> Nhom Then
            W = W + 1:                  Nhom = .Cells(J, "H").Value
            Arr(W, 2) = Nhom:           STT = 0
        Else
        End If
        STT = STT + 1:                   W = W + 1
        Arr(W, 1) = STT
        For Col = 2 To 6
            Arr(W, Col) = .Cells(J, Col).Value
        Next Col
    Next J
 End With
 If W Then
    [A2].Resize(W, 6).Value = Arr()
 End If
End Sub

Phần còn lại bạn tự ghi macro thử nha.

 

[Hello World Cup]

Cám ơn bạn rất nhiều

 

[Hello World Cup]

Mình xin gửi thêm đoạn mã sau khi tự ghi macro

Sub GopDuLieu()
 Dim Rws As Long, Col As Integer, STT As Integer, W As Integer, J As Long
 Dim Arr():                             Dim Nhom As String
 
 Sheets("KQ").Select:                   Rws = Sheets("KQ").UsedRange.Rows.Count
 Range("A2:G" & Rws).Delete
 With Sheets("Goc")
    Rws = .UsedRange.Rows.Count:        Col = .UsedRange.Columns.Count
    ReDim Arr(1 To 2 * Rws, 1 To Col)
    For J = 2 To Rws
        If .Cells(J, "H").Value <> Nhom Then
            W = W + 1:                  Nhom = .Cells(J, "H").Value
            Arr(W, 2) = Nhom:           STT = 0
            

        Else
        End If
        STT = STT + 1:                   W = W + 1
        Arr(W, 1) = STT
        For Col = 2 To 6
            Arr(W, Col) = .Cells(J, Col).Value
        Next Col
    Next J
 End With
 If W Then
    [A2].Resize(W, 6).Value = Arr()
 End If
 
 Dim i As Integer
 Dim lastRow As Integer
 Dim ws As Worksheet
 
 Set ws = Sheets("KQ")
 
 
 lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
 
 With Sheets("KQ")
    For i = 1 To lastRow
 
        If Cells(i, "A").Value = vbNullString And Cells(i, "B").Value <> vbNullString Then
            Range(Cells(i, "A"), Cells(i, "H")).Select
                Selection.Merge
                Selection.Font.Size = 12
                Selection.Font.Size = 14
                Selection.InsertIndent 1
                Selection.Font.Bold = True
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
        End If
    Next i
 End With
End Sub