Bạn chạy thử code sau:
Sub InsertRows()
Dim sArr(), Res(1 To 10000, 1 To 6), Header As Range
Dim I As Long, J As Long, K As Long, lR As Long, nR As Long
With Sheet1
lR = .Range("A" & Rows.Count).End(xlUp).Row
sArr() = .Range("A2:F" & lR).Value
Set Header = .Range("A1:F1")
End With
For I = 1 To UBound(sArr, 1)
K = K + 1
For J = 1 To 6
Res(K, J) = sArr(I, J)
Next J
If sArr(I, 4) > 1 Then
For nR = 1 To sArr(I, 4) - 1
K = K + 1
Res(K, 2) = sArr(I, 2): Res(K, 3) = CStr(sArr(I, 3))
Next nR
End If
Next I
Header.Copy Sheet2.Range("H1")
Sheet2.Range("H2").Resize(K, 6) = Res
Set Header = Nothing
MsgBox "Done", vbInformation, "GPE"
End Sub
Đây bạn xem.
Sub chuyendulieu()
Dim arr, arr1, lr As Long, i As Long, j As Long, a As Long, dk As Integer
With Sheet1
lr = .Range("B" & Rows.Count).End(xlUp).Row
If lr < 2 Then Exit Sub
arr = .Range("A2:F" & lr).Value
ReDim arr1(1 To UBound(arr, 1) * 50, 1 To 6)
For i = 1 To UBound(arr, 1)
a = a + 1
For j = 1 To 6
arr1(a, j) = arr(i, j)
Next j
dk = arr(i, 4) - 1
If dk > 0 Then
For j = 1 To dk
a = a + 1
arr1(a, 2) = arr(i, 2)
arr1(a, 3) = arr(i, 3)
Next j
End If
Next i
End With
With Sheet2
lr = .Range("B" & Rows.Count).End(xlUp).Row
If lr > 1 Then .Range("A2:F" & lr).ClearContents
If a Then .Range("A2").Resize(a, 6).Value = arr1
End With
End Sub
