Tạo code tạo Data theo mẫu (1 người xem)

[littlecat1987]

Nhờ mọi người tạo Code tạo Data theo mẫu:
- Nguồn: Nhập Dữ liệu
- Kết quả: Data sau khi chạy Code
Thanks!

 

[Hoang2013]

Sub TongHop()
 Dim Rws As Long, W As Long, Dg As Integer, Cot As Integer, Rw As Long, Col As Integer, Dm As Integer
 Dim Cls As Range
 With Sheets("Nguon")
    Rws = .[d4].CurrentRegion.Rows.Count
    Cot = .[d4].CurrentRegion.Columns.Count
    ReDim Arr(1 To Rws, 1 To 8)
    Sheets("Ket Qua").[A2].Resize(Rws, 7).Value = ClearContents
    For Each Cls In .Range("D5").Resize(Rws, Cot - 3)
        If Cls.Value > 0 Then
            Rw = Cls.Row:                       Col = Cls.Column
            W = W + 1:                          Arr(W, 1) = W
            For Dm = 1 To 3
                Arr(W, Dm + 1) = .Cells(Rw, Dm).Value
            Next Dm
            Arr(W, 4) = .Cells(1, Col).Value:    Arr(W, 5) = .Cells(2, Col).Value
            Arr(W, 6) = .Cells(4, Col).Value:    Arr(W, 7) = Cls.Value
        End If
    Next Cls
 End With
 If W Then
    Sheets("Ket Qua").[A2].Resize(W, 7).Value = Arr()
    Randomize
    Sheets("Ket Qua").[A1:C1].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
 End If
End Sub

 

[HieuCD]

Nhờ mọi người tạo Code tạo Data theo mẫu:
- Nguồn: Nhập Dữ liệu
- Kết quả: Data sau khi chạy Code
Cảm ơn!

Lỡ viết code

Sub LietKe()
  Dim sArr(), sR As Long, sC As Integer, Arr(), R As Long
  Dim i As Long, k As Long, j As Integer
 
  With Sheets("NGUON")
    sR = .Range("A" & Rows.Count).End(xlUp).Row
    sC = .Range("XFC1").End(xlToLeft).Column
    If sR < 5 Or sC < 4 Then MsgBox ("Khong có du lieu, thoat chuong trinh"): Exit Sub
    sArr = .Range("A1").Resize(sR, sC).Value
    R = Application.Count(.Range("D5").Resize(sR - 4, sC - 3))
    If R = 0 Then MsgBox ("Khong có du lieu, thoat chuong trinh"): Exit Sub
  End With
  ReDim Arr(1 To R, 1 To 7)
 
  For j = 4 To sC
    For i = 5 To sR
      tmp = sArr(i, j)
      If TypeName(tmp) = "Double" Then
        k = k + 1
        Arr(k, 1) = sArr(i, 1): Arr(k, 2) = sArr(i, 2): Arr(k, 3) = sArr(i, 3)
        Arr(k, 4) = sArr(1, j): Arr(k, 5) = sArr(2, j): Arr(k, 6) = sArr(4, j)
        Arr(k, 7) = tmp
      End If
    Next i
  Next j
 
  With Sheets("KET QUA")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("A2:G" & i).ClearContents
    .Range("A2").Resize(k, 7) = Arr
  End With
End Sub