Chèn 5 dòng trên những dòng có sẵn và lặp lại nội dung của cột thứ 1 và 2

[superhacker]

Chào các anh,
Em là người mới tập tành VBA nên còn rất gà mờ.
Em có 1 file excel (như đính kèm), Bây giờ em muốn chèn 5 dòng trên những dòng có sẵn và lặp lại nội dung của cột thứ 1 và 2 (kết quả như sheet 2).
Cứ lặp lại như thế cho đến dòng cuối cùng

Em mò mãi vẫn chưa ra được, mong các anh giúp đỡ.

Em xin cảm ơn!

 

[snow25]

Chào các anh,
Em là người mới tập tành VBA nên còn rất gà mờ.
Em có 1 file excel (như đính kèm), Bây giờ em muốn chèn 5 dòng trên những dòng có sẵn và lặp lại nội dung của cột thứ 1 và 2 (kết quả như sheet 2).
Cứ lặp lại như thế cho đến dòng cuối cùng

Em mò mãi vẫn chưa ra được, mong các anh giúp đỡ.

Em xin cảm ơn!

Bạn chạy thử code này xem.

Sub taomoi()
Const socanthem As Long = 5
Dim arr, arr1, lr As Long, i As Long, j As Integer, a As Long, k As Integer
With Sheet1
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr < 2 Then Exit Sub
     arr = .Range("A2:K" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * socanthem, 1 To UBound(arr, 2))
End With
    For i = 1 To UBound(arr, 1)
       For j = 1 To socanthem
           a = a + 1
           arr1(a, 1) = a
           For k = 2 To UBound(arr, 2)
               arr1(a, k) = arr(i, k)
           Next k
      Next j
   Next i
With Sheet2
      lr = .Range("A" & Rows.Count).End(xlUp).Row
      If lr > 1 Then .Range("A2:K" & lr).ClearContents
      If a Then .Range("A2").Resize(a, UBound(arr, 2)).Value = arr1
End With
End Sub

 

[Ba Tê]

Chào các anh,
Em là người mới tập tành VBA nên còn rất gà mờ.
Em có 1 file excel (như đính kèm), Bây giờ em muốn chèn 5 dòng trên những dòng có sẵn và lặp lại nội dung của cột thứ 1 và 2 (kết quả như sheet 2).
Cứ lặp lại như thế cho đến dòng cuối cùng

Em mò mãi vẫn chưa ra được, mong các anh giúp đỡ.

Em xin cảm ơn!

Phải là "lặp lại nội dung cột thứ hai và thứ ba" (B, C)

Public Sub sGpe()
Const CoL As Long = 11
Dim sArr(), dArr(), I As Long, J As Long, K As Long, N As Long, R As Long
sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, CoL).Value
R = UBound(sArr)
ReDim dArr(1 To R * 6, 1 To CoL)
For I = 1 To R
    For N = 1 To 5
        K = K + 1
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    Next N
    K = K + 1
    dArr(K, 1) = K
    For J = 2 To CoL
        dArr(K, J) = sArr(I, J)
    Next J
Next I
Sheet2.Range("A2").Resize(1000, CoL).ClearContents
Sheet2.Range("A2").Resize(K, CoL) = dArr
End Sub

 

[be_09]

Chào các anh,
Em là người mới tập tành VBA nên còn rất gà mờ.
Em có 1 file excel (như đính kèm), Bây giờ em muốn chèn 5 dòng trên những dòng có sẵn và lặp lại nội dung của cột thứ 1 và 2 (kết quả như sheet 2).
Cứ lặp lại như thế cho đến dòng cuối cùng

Em mò mãi vẫn chưa ra được, mong các anh giúp đỡ.

Em xin cảm ơn!

Thử code sau:

Sub Insert_Copy()
Application.ScreenUpdating = False
    Dim I As Long
    Dim Them As Integer
    Sheet2.UsedRange.Offset(1).ClearContents
    Sheet1.Range("A1").CurrentRegion.Offset(1, 1).Copy Destination:=Sheet2.Range("B2")
    
    Them = 5 'Thêm 5 dòng
    For I = Cells(Rows.Count, 2).End(xlUp).Offset(1).Row To 2 Step -1
        Rows(I).Copy
        Rows(I).Resize(Them).Insert
    Next
Application.ScreenUpdating = True
End Sub

 

[superhacker]

Em cảm ơn các anh/chị rất nhiều.
Cả 3 phương pháp trên đều rất hay và bổ ích.

Em đã học thêm được rất nhiều từ các anh/chị.

Một lần nữa em xin chân thành cảm ơn!

 

[superhacker]

Phải là "lặp lại nội dung cột thứ hai và thứ ba" (B, C)

Public Sub sGpe()
Const CoL As Long = 11
Dim sArr(), dArr(), I As Long, J As Long, K As Long, N As Long, R As Long
sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, CoL).Value
R = UBound(sArr)
ReDim dArr(1 To R * 6, 1 To CoL)
For I = 1 To R
    For N = 1 To 5
        K = K + 1
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    Next N
    K = K + 1
    dArr(K, 1) = K
    For J = 2 To CoL
        dArr(K, J) = sArr(I, J)
    Next J
Next I
Sheet2.Range("A2").Resize(1000, CoL).ClearContents
Sheet2.Range("A2").Resize(K, CoL) = dArr
End Sub

Cảm ơn anh đã nhắc nhở. Đúng là em nhầm thật. Vì cột No. Là không cần thiết nên phiền anh giúp em lần nữa được không ạ?
Cụ thể như file em đính kèm đó ạ.


Em xin cảm ơn!

 

[be_09]

Cảm ơn anh đã nhắc nhở. Đúng là em nhầm thật. Vì cột No. Là không cần thiết nên phiền anh giúp em lần nữa được không ạ?
Cụ thể như file em đính kèm đó ạ.


Em xin cảm ơn!

Sửa code bài 4 lại 1 tí:

Sub Insert_Copy()
Application.ScreenUpdating = False
    Dim I As Long
    Dim Them As Integer
    Sheet2.UsedRange.Offset(1).ClearContents
    Sheet1.Range("A1").CurrentRegion.Offset(1).Copy Destination:=Sheet2.Range("A2")
    
    Them = 4 'Thêm 4 dòng
    For I = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row To 2 Step -1
        Rows(I).Copy
        Rows(I).Resize(Them).Insert
    Next
Application.ScreenUpdating = True
End Sub

 

[superhacker]

Sửa code bài 4 lại 1 tí:

Sub Insert_Copy()
Application.ScreenUpdating = False
    Dim I As Long
    Dim Them As Integer
    Sheet2.UsedRange.Offset(1).ClearContents
    Sheet1.Range("A1").CurrentRegion.Offset(1).Copy Destination:=Sheet2.Range("A2")
   
    Them = 4 'Thêm 4 dòng
    For I = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row To 2 Step -1
        Rows(I).Copy
        Rows(I).Resize(Them).Insert
    Next
Application.ScreenUpdating = True
End Sub

Cảm ơn anh!

Nhưng em chỉ cần copy nội dung của 2 cột Item 1 và Item 2 thôi ạ.
Các cột khác anh bỏ dùm em đc ko ạ?

 

[be_09]

Cảm ơn anh!

Nhưng em chỉ cần copy nội dung của 2 cột Item 1 và Item 2 thôi ạ.
Các cột khác anh bỏ dùm em đc ko ạ?

Chỉ áp dụng cho cột A và B, nếu muốn thêm thì sửa Columns("A:B") thành cái gì đó.

Sub Insert_Copy()
Application.ScreenUpdating = False
    Dim I As Long
    Dim Them As Integer
    Sheet2.UsedRange.Offset(1).ClearContents
    Sheet1.UsedRange.Columns("A:B").Offset(1).Copy Destination:=Sheet2.Range("A2")
    Them = 4 'Thêm 4 dòng
    For I = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row To 2 Step -1
        Rows(I).Copy
        Rows(I).Resize(Them).Insert
    Next
Application.ScreenUpdating = True
End Sub

 

[Ba Tê]

Cảm ơn anh đã nhắc nhở. Đúng là em nhầm thật. Vì cột No. Là không cần thiết nên phiền anh giúp em lần nữa được không ạ?
Cụ thể như file em đính kèm đó ạ.

Các dòng thêm bên trên chỉ lấy dữ liệu 2 cột A, B.
Thay đổi Rws, CoL bằng bao nhiêu tùy bạn.

Public Sub sGpe()
Const CoL As Long = 11 ' So cot bang du lieu'
Const Rws As Long = 4 ' So dong can them ben tren'
Dim sArr(), dArr(), I As Long, J As Long, K As Long, N As Long, R As Long
sArr = Sheets("Raw").Range("A2", Sheets("Raw").Range("A2").End(xlDown)).Resize(, CoL).Value
R = UBound(sArr)
ReDim dArr(1 To R * (Rws + 1), 1 To CoL)
For I = 1 To R
    For N = 1 To Rws
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
    Next N
    K = K + 1
    For J = 1 To CoL
        dArr(K, J) = sArr(I, J)
    Next J
Next I
With Sheets("Complete")
    .Range("A2").Resize(10000, CoL).ClearContents
    .Range("A2").Resize(K, CoL) = dArr
End With
End Sub

 

[superhacker]

Cảm ơn các anh rất nhiều ạ.