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

Liên hệ QC

Người dùng đang xem chủ đề này

Tôi tuân thủ nội quy khi đăng bài

Hello World Cup

Thành viên mới
Tham gia
23/12/22
Bài viết
18
Được thích
2
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ạng222.png.

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.
 

File đính kèm

Đây là phần cốt lõi của macro mà bạn cần:
PHP:
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.
 
Upvote 0
Mình xin gửi thêm đoạn mã sau khi tự ghi macro :)
Mã:
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
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom