Hỏi cao nhân macro và VBA về tự động insert và copy dòng

[phuong_ck]

em đang có bảng công thức như bên dưới, có cách nào để dùng Macro hoặc VBA để nó tự động insert và copy theo số lượng xe không ạ. Em cảm ơn các anh chị trước

Bảng nguồn

Đơn hàng	Số lượng xe	Khối lượng/ xe (Tấn)	Cước vận tải/ xe
Đơn hàng 1	2	25	1,000,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 3	10	21	3,600,000
Đơn hàng 4	8	15	2,850,000
Đơn hàng 5	2	19	1,900,000
Đơn hàng 6	5	18	7,800,000

Mong muốn (tự insert và copy như đơn hàng 1 & đơn hàng 2)

Đơn hàng	Số lượng xe	Khối lượng/ xe (Tấn)	Cước vận tải/ xe
Đơn hàng 1	2	25	1,000,000
Đơn hàng 1	2	25	1,000,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 2	5	23	2,500,000
Đơn hàng 3	10	21	3,600,000
Đơn hàng 4	8	15	2,850,000
Đơn hàng 5	2	19	1,900,000
Đơn hàng 6	5	18	7,800,000

 

[Vy.Nguyễn]

hay

 

[hoamattroicoi]

Sub insert_Banghi()
Dim i As Long, j As Long, k As Long, Tongdong As Long
Dim sArr(), dArr()
    Tongdong = 0
    sArr = Sheet1.Range("A2:D" & Sheet1.[A65536].End(xlUp).Row).Value
    For i = 1 To UBound(sArr, 1)
        Tongdong = Tongdong + sArr(i, 2)
    Next
ReDim dArr(1 To Tongdong, 1 To 5)
    For i = 1 To UBound(sArr, 1)
        For j = 1 To sArr(i, 2)
            k = k + 1
            dArr(k, 1) = sArr(i, 1)
            dArr(k, 2) = sArr(i, 2)
            dArr(k, 3) = sArr(i, 3)
            dArr(k, 4) = sArr(i, 4)
        Next
    Next
Sheet2.Range("A2:D10000").ClearContents
If k Then Sheet2.[A2].Resize(k, 4) = dArr
End Sub

Bạn chạy code này trong file đính kèm nhé
Inbox mình gửi file đính kèm cho nhé, hình như tài khoản của mình chưa có quyền up file đính kèm thì phải.