Copy paste nhiều lần

[ngochieu258]

Kính nhờ anh/chị.
Hiện tại em muồn copy một vùng ở một sheet sang sheet khác một số lần nhất định, sau đó sắp xếp lại vùng vừa paste theo thứ tự tăng dần ạ. Mong các anh chị cho em một code để xử lý ạ. Em đính kèm theo file ví dụ ạ

 

[ducdoom]

Chào bạn, mình có thử viết code này, không biết đúng ý của bạn không?

Sub Copy_8_times()

Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")

Dim last_row As Long
Dim i As Long

For i = 1 To 8
last_row = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A" & last_row + 1).Resize(12, 2).Value2 = ws1.Range("A1:B12").Value2
Next

last_row = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A2", "B" & last_row).Sort key1:=ws2.Range("A1"), order1:=xlAscending, Header:=xlNo

End Sub

 

[HeSanbi]

ducdoom
Khi viết đoạn code để giúp đỡ hoặc đặt câu hỏi bạn gõ tuần tự:
[ C O D E = p h p ]
Code của bạn ở đây
[ / C O D E ]
hoặc vào các chỉ mục chọn "Chèn" chọn "Mã", để xem lại click nút bánh xe.

Code dưới đây chỉ chỉnh một tí cho đúng chuẩn mực viết code (chưa xem qua file):

Sub Copy_8_times()
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Dim last_row&, i&, row&, col%
        row = 12: col = 2
    last_row = ws2.Range("A" & Rows.Count).End(xlUp).Row
    last_row = IIf(last_row <= 1, 1, last_row) 'Bắt đầu từ A2 nên để 1 -> last_row + 1 >= 2
    Application.ScreenUpdating = False
    For i = 1 To 8
        DoEvents
        If i > 1 then last_row = last_row + row
        ws2.Range("A" & last_row + 1).Resize(row, col).Value2 = ws1.Range("A1").Resize(row, col).Value2
    Next
    ws2.Range("A2", "B" & last_row + row).Sort key1:=ws2.Range("A1"), order1:=xlAscending, Header:=xlNo
Ends: Set ws1 = Nothing: Set ws2 = Nothing
Application.ScreenUpdating = True
End Sub

 

[be_09]

Kính nhờ anh/chị.
Hiện tại em muồn copy một vùng ở một sheet sang sheet khác một số lần nhất định, sau đó sắp xếp lại vùng vừa paste theo thứ tự tăng dần ạ. Mong các anh chị cho em một code để xử lý ạ. Em đính kèm theo file ví dụ ạ

Bạn nên sửa tiêu đề là "Copy và Paste lặp với số lần mong muốn".

Thử code sau:
1/ Tại sheet1 dữ liệu từ A2:B2 trở xuống bạn thêm bao nhiêu là tùy ý.
2/ Bạn muốn lặp bao nhiêu lần thì gõ con số muốn lặp vào D1 của sheet1.

Sub Copy_Loop()
    Dim i, y As Integer
    y = Sheet1.Range("D1").Value 'Nhâp só làn Loop vào D1
    Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
    Sheet1.Range("A1").CurrentRegion.Offset(1).Copy
 
    For i = 1 To y
        Sheet2.Range("A10000").End(xlUp).Offset(1).PasteSpecial
    Next i
    Sheet1.Range("A2").Select
End Sub

 

[ngochieu258]

r sodong = 1 To tongdong
Selection.EntireRow.Insert

Chào bạn, mình có thử viết code này, không biết đúng ý của bạn không?

Sub Copy_8_times()

Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")

Dim last_row As Long
Dim i As Long

For i = 1 To 8
last_row = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A" & last_row + 1).Resize(12, 2).Value2 = ws1.Range("A1:B12").Value2
Next

last_row = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A2", "B" & last_row).Sort key1:=ws2.Range("A1"), order1:=xlAscending, Header:=xlNo

End Sub

ducdoom
Khi viết đoạn code để giúp đỡ hoặc đặt câu hỏi bạn gõ tuần tự:
[ C O D E = p h p ]
Code của bạn ở đây
[ / C O D E ]
hoặc vào các chỉ mục chọn "Chèn" chọn "Mã", để xem lại click nút bánh xe.

Code dưới đây chỉ chỉnh một tí cho đúng chuẩn mực viết code (chưa xem qua file):

Sub Copy_8_times()
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Dim last_row&, i&, row&, col%
        row = 12: col = 2
    last_row = ws2.Range("A" & Rows.Count).End(xlUp).Row
    last_row = IIf(last_row <= 1, 1, last_row) 'Bắt đầu từ A2 nên để 1 -> last_row + 1 >= 2
    Application.ScreenUpdating = False
    For i = 1 To 8
        DoEvents
        If i > 1 then last_row = last_row + row
        ws2.Range("A" & last_row + 1).Resize(row, col).Value2 = ws1.Range("A1").Resize(row, col).Value2
    Next
    ws2.Range("A2", "B" & last_row + row).Sort key1:=ws2.Range("A1"), order1:=xlAscending, Header:=xlNo
Ends: Set ws1 = Nothing: Set ws2 = Nothing
Application.ScreenUpdating = True
End Sub

Sub Copy_Loop() Dim i, y As Integer y = Sheet1.Range("D1").Value 'Nhâp só làn Loop vào D1 Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents Sheet1.Range("A1").CurrentRegion.Offset(1).Copy For i = 1 To y Sheet2.Range("A10000").End(xlUp).Offset(1).PasteSpecial Next i Sheet1.Range("A2").Select End Sub

Em cảm ơn mọi người ạ. Em chạy thử thấy cách nào cũng được và đúng ý em