[Giúp] Xin code VBA copy và paste vùng dữ liệu

Liên hệ QC

nhatnguyenspkt

Thành viên mới
Tham gia
16/6/14
Bài viết
20
Được thích
1
Giới tính
Nam
Nhờ các A/C hướng đã code copy và paste vùng dữ liệu trong sheet:
Ví dụ như file đính kèm: copy vùng B2:J15 và tìm chỗ trống cuối cùng ô B(n) (theo ví dụ thì là B16) để paste vùng đã chọn;
Cảm ơn A/C nhiều!!!
 

File đính kèm

  • Book1.xlsx
    20.6 KB · Đọc: 41
Lần chỉnh sửa cuối:
Bạn dùng theo cách này thử xem.
Sub CopyRange(R1 As Range, Ce As Range)
R1.Select
Selection.Copy
Ce.Select
ActiveSheet.Paste
End Sub
Sub Test()
CopyRange Range(Cells(2, 2), Cells(15, 10)), Range(Cells(16, 2), Cells(16, 2))
' Copy B2:J15 v? paste vao B16
End Sub
 

File đính kèm

  • Book1.xlsm
    27.1 KB · Đọc: 45
Nhờ các A/C hướng đã code copy và paste vùng dữ liệu trong sheet:
Ví dụ như file đính kèm: copy vùng B2:J15 và tìm chỗ trống cuối cùng ô B(n) (theo ví dụ thì là B16) để paste vùng đã chọn;
Cảm ơn A/C nhiều!!!
Bạn thử:
PHP:
Sub Test()
    Dim LR As Long
    LR = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Range("B2:J" & LR).Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
End Sub
 
Bạn dùng theo cách này thử xem.
Sub CopyRange(R1 As Range, Ce As Range)
R1.Select
Selection.Copy
Ce.Select
ActiveSheet.Paste
End Sub
Sub Test()
CopyRange Range(Cells(2, 2), Cells(15, 10)), Range(Cells(16, 2), Cells(16, 2))
' Copy B2:J15 v? paste vao B16
End Sub
Cám ơn Anh, nhưng code này nó chỉ paste được 1 lần, e paste lần nữa thì nó ko tịnh tiến vùng paste xuống
Bài đã được tự động gộp:

Bạn thử:
PHP:
Sub Test()
    Dim LR As Long
    LR = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Range("B2:J" & LR).Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
End Sub
Cám ơn Anh đã chia sẽ,
Em muốn vùng copy là cố định, rồi paste vùng chọn đó xuống vùng trống đầu tiên bên dưới,
Nhờ Anh xem lại giúp Em với,
 
Vậy bạn thay dòng:
PHP:
Range("B2:J" & LR).Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
thành:
PHP:
Range("B2:J15").Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
Hoặc thành:
PHP:
 Selection.Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
 
Vậy bạn thay dòng:
PHP:
Range("B2:J" & LR).Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
thành:
PHP:
Range("B2:J15").Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
Hoặc thành:
PHP:
 Selection.Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)

Dạ được theo ý nhưng lại còn thiếu cái này: copy theo kiểu mình chọn cả hàng (từ 2:15) do e có tạo nhóm (file đính kèm), nếu copy như hiện tại thì mất thuộc tính nhóm sau khi paste.

Em cám ơn Anh!
 

File đính kèm

  • Book1.xlsm
    29.3 KB · Đọc: 24
Lần chỉnh sửa cuối:
Dạ được theo ý nhưng lại còn thiếu cái này: copy theo kiểu mình chọn cả hàng (từ 2:15) do e có tạo nhóm (file đính kèm), nếu copy như hiện tại thì mất thuộc tính nhóm sau khi paste.

Em cám ơn Anh!
Bạn không đưa ra vài kết quả Copy nên chẳng ai hiểu ý bạn muốn thế nào?
Thử code sau (hên thì trúng).
Mã:
Sub Nhap_Lieu()
    Sheet1.Range("B2").CurrentRegion.Offset(1).Copy
    Sheet2.[C10000].End(xlUp).Offset(1, -1).PasteSpecial Paste:=xlPasteValues
End Sub
 
Bạn không đưa ra vài kết quả Copy nên chẳng ai hiểu ý bạn muốn thế nào?
Thử code sau (hên thì trúng).
Mã:
Sub Nhap_Lieu()
    Sheet1.Range("B2").CurrentRegion.Offset(1).Copy
    Sheet2.[C10000].End(xlUp).Offset(1, -1).PasteSpecial Paste:=xlPasteValues
End Sub
Dạ để e trình bày lại, ý e là khi copy xuống dưới thì có cả thuộc tính tạo group e đã tạo ở vùng chọn (như file e có đính kèm)
Em cám ơn
 

File đính kèm

  • Chinh lai.xlsm
    31.2 KB · Đọc: 23
Dạ để e trình bày lại, ý e là khi copy xuống dưới thì có cả thuộc tính tạo group e đã tạo ở vùng chọn (như file e có đính kèm)
Em cám ơn
Thử lại:
Mã:
Sub
Nhap_Lieu()
    Sheet1.Range("B2:J15").Copy
    Sheet2.[C10000].End(xlUp).Offset(1, -1).PasteSpecial
End Sub
 
Cho em xin code copy từ dòng số 2 đến dòng số 15, và paste đến dòng trắng đầu tiên bên dưới ạ (ví dụ đính kèm là dòng thứ 16 ạ)

Em các ơn các A/C nhiều!!
 
Thử lại:
Mã:
Sub
Nhap_Lieu()
    Sheet1.Range("B2:J15").Copy
    Sheet2.[C10000].End(xlUp).Offset(1, -1).PasteSpecial
End Sub

Cho em xin code copy từ dòng số 2 đến dòng số 15, và paste đến dòng trắng đầu tiên bên dưới ạ (ví dụ đính kèm là dòng thứ 16 ạ)

Em các ơn ạ!!
 

File đính kèm

  • Chinh lai.xlsm
    29.1 KB · Đọc: 27
Bạn thử:
PHP:
Sub Test()
    Dim LR As Long
    LR = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Range("B2:J" & LR).Copy Range("C" & Rows.Count).End(xlUp).Offset(1, -1)
End Sub
Cảm ơn anh, em làm được rồi.
Em muốn thêm khi copy sang thì copy cả ngày và số phiếu thì làm cách nào ạ
Và có cách nào copy khác cột không ạ
 

File đính kèm

  • pnk.xlsx
    15.1 KB · Đọc: 63
Cảm ơn anh, em làm được rồi.
Em muốn thêm khi copy sang thì copy cả ngày và số phiếu thì làm cách nào ạ
Và có cách nào copy khác cột không ạ
Bạn thử:
PHP:
Sub Test() 
    Dim Rng1 As Range, Rng2 As Range, LR As Long
    Set Rng1 = Sheets("PNK").Range("B4:E" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Set Rng2 = Sheets("PNK").Range("F4:F" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Application.ScreenUpdating = 0
    Sheets("DLNK").Select
    With Sheets("DLNK")
        Rng1.Copy .Range("D" & .Rows.Count).End(3).Offset(1)
        Rng2.Copy .Range("J" & .Rows.Count).End(3).Offset(1)
        Sheets("PNK").[C1].Copy .Range("A" & .Rows.Count).End(3).Offset(1)
        Sheets("PNK").[F1].Copy .Range("B" & .Rows.Count).End(3).Offset(1)
    End With
    LR = Sheets("DLNK").Range("D" & Rows.Count).End(xlUp).Row
    Range("A2").Copy Destination:=Range("a3:a" & LR)
    Range("B2").Copy Destination:=Range("B3:B" & LR)
    Application.ScreenUpdating = 1
    Sheets("PNK").Select
End Sub
 
Cảm ơn anh, em làm được rồi.
Em muốn thêm khi copy sang thì copy cả ngày và số phiếu thì làm cách nào ạ
Và có cách nào copy khác cột không ạ
Góp ý cho bạn:
1/ Để nhập liệu nhanh thì cần có 1 sheet chứa danh mục hàng hóa.
2/ 1 sheet danh mục khách hàng.
3/ Phiếu nhập kho nên có thêm tên khách hàng cung cấp, địa chỉ, số điện thoại.
 
Bạn thử:
PHP:
Sub Test()
    Dim Rng1 As Range, Rng2 As Range, LR As Long
    Set Rng1 = Sheets("PNK").Range("B4:E" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Set Rng2 = Sheets("PNK").Range("F4:F" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Application.ScreenUpdating = 0
    Sheets("DLNK").Select
    With Sheets("DLNK")
        Rng1.Copy .Range("D" & .Rows.Count).End(3).Offset(1)
        Rng2.Copy .Range("J" & .Rows.Count).End(3).Offset(1)
        Sheets("PNK").[C1].Copy .Range("A" & .Rows.Count).End(3).Offset(1)
        Sheets("PNK").[F1].Copy .Range("B" & .Rows.Count).End(3).Offset(1)
    End With
    LR = Sheets("DLNK").Range("D" & Rows.Count).End(xlUp).Row
    Range("A2").Copy Destination:=Range("a3:a" & LR)
    Range("B2").Copy Destination:=Range("B3:B" & LR)
    Application.ScreenUpdating = 1
    Sheets("PNK").Select
End Sub
:wow: :wow: Wow. Cảm ơn anh rất nhiều. Em sẽ tìm hiểu mấy code này
Bài đã được tự động gộp:

Góp ý cho bạn:
1/ Để nhập liệu nhanh thì cần có 1 sheet chứa danh mục hàng hóa.
2/ 1 sheet danh mục khách hàng.
3/ Phiếu nhập kho nên có thêm tên khách hàng cung cấp, địa chỉ, số điện thoại.
Dạ. Cảm ơn anh đã góp ý. Em sẽ học hỏi thêm
 
Bạn thử:
PHP:
    Range("A2").Copy Destination:=Range("a3:a" & LR)
    Range("B2").Copy Destination:=Range("B3:B" & LR)
Anh ơi, Nếu em sửa dữ liệu ô C1 và ô F1 thì cột A2 và B2 sẽ bị thay đổi theo hết luôn chứ không giữ nguyên dữ liệu trước
PHP:
Sheets("PNK").[C1]
Sheets("PNK").[F1]
 
Anh ơi, Nếu em sửa dữ liệu ô C1 và ô F1 thì cột A2 và B2 sẽ bị thay đổi theo hết luôn chứ không giữ nguyên dữ liệu trước
PHP:
Sheets("PNK").[C1]
Sheets("PNK").[F1]
Bạn sửa thành thế này xem:
PHP:
Sub Test()
    Dim Rng1 As Range, Rng2 As Range, LR As Long, R As Long
    Set Rng1 = Sheets("PNK").Range("B4:E" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Set Rng2 = Sheets("PNK").Range("F4:F" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    R = Rng1.Rows.Count
    Application.ScreenUpdating = 0
    With Sheets("DLNK")
        LR = .Range("D" & Rows.Count).End(xlUp).Row + 1
        .Range("D" & LR).Resize(R, 4).Value = Rng1.Value
        .Range("J" & LR).Resize(R).Value = Rng2.Value
        .Range("A" & LR).Resize(R).Value = Sheets("PNK").Range("C1").Value
        .Range("B" & LR).Resize(R).Value = Sheets("PNK").Range("F1").Value
        .Range("A" & LR).Resize(R, 10).Borders.LineStyle = 1
    End With
    Application.ScreenUpdating = 1
End Sub
 
Bạn sửa thành thế này xem:
PHP:
Sub Test()
    Dim Rng1 As Range, Rng2 As Range, LR As Long, R As Long
    Set Rng1 = Sheets("PNK").Range("B4:E" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Set Rng2 = Sheets("PNK").Range("F4:F" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    R = Rng1.Rows.Count
    Application.ScreenUpdating = 0
    With Sheets("DLNK")
        LR = .Range("D" & Rows.Count).End(xlUp).Row + 1
        .Range("D" & LR).Resize(R, 4).Value = Rng1.Value
        .Range("J" & LR).Resize(R).Value = Rng2.Value
        .Range("A" & LR).Resize(R).Value = Sheets("PNK").Range("C1").Value
        .Range("B" & LR).Resize(R).Value = Sheets("PNK").Range("F1").Value
        .Range("A" & LR).Resize(R, 10).Borders.LineStyle = 1
    End With
    Application.ScreenUpdating = 1
End Sub
Hay quá anh. Mà em ko thấy có thuộc tính copy, làm sao dữ liệu chuyển được sang hay vậy anh.
 
Bạn sửa thành thế này xem:
PHP:
Sub Test()
    Dim Rng1 As Range, Rng2 As Range, LR As Long, R As Long
    Set Rng1 = Sheets("PNK").Range("B4:E" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    Set Rng2 = Sheets("PNK").Range("F4:F" & Sheets("PNK").Cells(Rows.Count, "B").End(3).Row)
    R = Rng1.Rows.Count
    Application.ScreenUpdating = 0
    With Sheets("DLNK")
        LR = .Range("D" & Rows.Count).End(xlUp).Row + 1
        .Range("D" & LR).Resize(R, 4).Value = Rng1.Value
        .Range("J" & LR).Resize(R).Value = Rng2.Value
        .Range("A" & LR).Resize(R).Value = Sheets("PNK").Range("C1").Value
        .Range("B" & LR).Resize(R).Value = Sheets("PNK").Range("F1").Value
        .Range("A" & LR).Resize(R, 10).Borders.LineStyle = 1
    End With
    Application.ScreenUpdating = 1
End Sub
giúp em bẫy lỗi nếu để trống không nhập dữ liệu với ạ
 
Web KT
Back
Top Bottom