Nhờ anh/chị giúp code VBA copy số dòng lặp lại

[tranquynh81]

CHO MÌNH HỎI, MÌNH CÓ SỐ LIỆU BAN ĐẦU Ở CỘT A , MÌNH MUỐN COPY DỮ LIỆU SANG CỘT C
TRÂN TRỌNG CẢM ƠN

 

[VetMini]

Bài viết hoa cả cụm đọc mỏi mắt quá.
Thớt cần đọc lại nội quy diễn đàn.

 

[tranquynh81]

Tại vì mình mới vào diễn đàn không biết nội quy. Mong diễn đàn "giaiphapexcel.com" thông cảm
Nhờ giúp đỡ . trân trọng cảm ơn

 

[bebo021999]

Quy luật thế nào bạn? Cách 4 dòng copy vô C, kế tiếp vô D đúng không?

 

[tranquynh81]

Dạ đúng ruh ạ . Cách 4 dòng copy vô C, kế tiếp vô D, sau đó copy 4 ô tiếp theo của cột A dán vào dưới cột C, sau đó lại copy 4 ô tiếp theo ở cột A dán vào dưới cột D.

cảm ơn đã quan tâm giúp đỡ

 

[VetMini]

Tại vì mình mới vào diễn đàn không biết nội quy. Mong diễn đàn "giaiphapexcel.com" thông cảm
Nhờ giúp đỡ . trân trọng cảm ơn

Bạn nói dối 2 lần:
1. Lúc bạn đăng ký gia nhập. Có câu hỏi "đã đọc nội quy...". Phải trả lời "đã đọc và đồng ý" mới được đăng ký. Bây giờ bạn nói là "không biết nội quy" là nói dối.
2. Theo lý lịch thì bạn đăng nhập diễn đàn đã 12 năm. Bây giờ bạn khai ra là "mới vào" là thế nào?

Nội quy, mục II. Hình thức bài viết, tiểu mục 3


Nhưng mà thôi. Không cần dây dưa thêm. Người viết bài #4 đã tỏ ý muốn viết giùm bạn. Nội quy không thành vấn đề nữa.

 

[tranquynh81]

Bạn nói dối 2 lần:
1. Lúc bạn đăng ký gia nhập. Có câu hỏi "đã đọc nội quy...". Phải trả lời "đã đọc và đồng ý" mới được đăng ký. Bây giờ bạn nói là "không biết nội quy" là nói dối.
2. Theo lý lịch thì bạn đăng nhập diễn đàn đã 12 năm. Bây giờ bạn khai ra là "mới vào" là thế nào?

Nội quy, mục II. Hình thức bài viết, tiểu mục 3
View attachment 280357

Nhưng mà thôi. Không cần dây dưa thêm. Người viết bài #4 đã tỏ ý muốn viết giùm bạn. Nội quy không thành vấn đề nữa.

Trân trọng xin lỗi tất cả mọi người!
Mong mọi người thông cảm!

 

[Quangthanh_hocvba]

Dạ đúng ruh ạ . Cách 4 dòng copy vô C, kế tiếp vô D, sau đó copy 4 ô tiếp theo của cột A dán vào dưới cột C, sau đó lại copy 4 ô tiếp theo ở cột A dán vào dưới cột D.

cảm ơn đã quan tâm giúp đỡ

Cái này dùng for là ok rồi bạn ạ kèm theo đk là chia hết cho 4 nhé

 

[bebo021999]

Option Explicit
Sub copyBlock()
Dim lr&, i&, j&, k&, t&, rng, arr1(), arr2()
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A1:A" & lr).Value
ReDim arr1(1 To lr, 1 To 1)
ReDim arr2(1 To lr, 1 To 1)
For i = 1 To lr
    If Int((i - 1) / 4) Mod 2 = 0 Then
        k = k + 1
        arr1(k, 1) = rng(i, 1)
    Else
        t = t + 1
        arr2(t, 1) = rng(i, 1)
    End If
Next
Range("C1:D10000").ClearContents
Range("C1").Resize(k, 1).Value = arr1
Range("D1").Resize(t, 1).Value = arr2
End Sub

 

[BuiQuangThuan]

Định đưa code lên cùng mọi người tham khảo mà thấy bài #1 chữ vẫn để in hoa. Đành thôi vậy mặc dù đã có câu này

Trân trọng xin lỗi tất cả mọi người!
Mong mọi người thông cảm!

 

[tranquynh81]

Option Explicit
Sub copyBlock()
Dim lr&, i&, j&, k&, t&, rng, arr1(), arr2()
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A1:A" & lr).Value
ReDim arr1(1 To lr, 1 To 1)
ReDim arr2(1 To lr, 1 To 1)
For i = 1 To lr
    If Int((i - 1) / 4) Mod 2 = 0 Then
        k = k + 1
        arr1(k, 1) = rng(i, 1)
    Else
        t = t + 1
        arr2(t, 1) = rng(i, 1)
    End If
Next
Range("C1:D10000").ClearContents
Range("C1").Resize(k, 1).Value = arr1
Range("D1").Resize(t, 1).Value = arr2
End Sub

Cảm ơn bebo021999 nhiều . cảm ơn các a/c đã giúp đỡ

 

[tranquynh81]

Option Explicit
Sub copyBlock()
Dim lr&, i&, j&, k&, t&, rng, arr1(), arr2()
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A1:A" & lr).Value
ReDim arr1(1 To lr, 1 To 1)
ReDim arr2(1 To lr, 1 To 1)
For i = 1 To lr
    If Int((i - 1) / 4) Mod 2 = 0 Then
        k = k + 1
        arr1(k, 1) = rng(i, 1)
    Else
        t = t + 1
        arr2(t, 1) = rng(i, 1)
    End If
Next
Range("C1:D10000").ClearContents
Range("C1").Resize(k, 1).Value = arr1
Range("D1").Resize(t, 1).Value = arr2
End Sub

Các a/c , Mr bebo021999 có thể giúp mình thêm 1 bước nữa được không. mình có đính kèm file.
Cảm ơn các a/c đã giúp đỡ

 

[bebo021999]

Option Explicit
Sub copyBlock()
Dim lr&
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C1:C1000").ClearContents
Range("A1:A" & WorksheetFunction.Ceiling(lr - 5, 4)).Copy Range("C1")
Range("A5:A" & lr).Copy Range("D1")
End Sub

 

[tranquynh81]

Option Explicit
Sub copyBlock()
Dim lr&
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C1:C1000").ClearContents
Range("A1:A" & WorksheetFunction.Ceiling(lr - 5, 4)).Copy Range("C1")
Range("A5:A" & lr).Copy Range("D1")
End Sub

Cảm ơn @bebo021999 rất nhiều đã giúp đỡ
Trân trọng cảm ơn