Tự động copy 1 khối cell sau khi chọn 1 cell đã quy định (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

hoanglocphat

Thành viên thường trực
Tham gia
27/1/13
Bài viết
258
Được thích
30
Chào các bạn,
Do tính chất công việc thường xuyên lặp lại, nay nhờ các bạn viết code như sau:
Tôi có 2 khối ô mà thường xuyên copy như sau:
1/ K10:P10
2/ H16:M16
Nay tôi muốn khi chọn bất cứ 1 ô nào trong K10:P10 thì nó tự động copy K10:P10 hoặc chọn 1 ô trong H16:M16 thì nó tự động copy khối ô H16:M16
Sau khi copy thì tôi paste bất kỳ vào 1 khối cell nào đó
Và nếu được thì tôi muốn là paste value ở khối cell mà tôi muốn paste
Cảm ơn các bạn.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
hoanglocphat đã viết:
Chào các bạn,
Do tính chất công việc thường xuyên lặp lại, nay nhờ các bạn viết code như sau:
Tôi có 2 khối ô mà thường xuyên copy như sau:
1/ K10:p10
2/ H16:M16
Nay tôi muốn khi chọn bất cứ 1 ô nào trong K10:p10 thì nó tự động copy K10:p10 hoặc chọn 1 ô trong H16:M16 thì nó tự động copy khối ô H16:M16
Sau khi copy thì tôi paste bất kỳ vào 1 khối cell nào đó
Và nếu được thì tôi muốn là paste value ở khối cell mà tôi muốn paste
Cảm ơn các bạn.
Nhấp chuột vào đây để mở rộng...
Bạn dùng code này cho Sheet chứa dữ liệu cần copy nhé!
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy Cls
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("H16:M16").Copy Cls
    End If
End Sub
 
Upvote 0
vanthinh3101 đã viết:
Bạn dùng code này cho Sheet chứa dữ liệu cần copy nhé!
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy Cls
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("H16:M16").Copy Cls
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, mình muốn Paste value được không bạn!
 
Upvote 0
hoanglocphat đã viết:
Cảm ơn bạn, mình muốn Paste value được không bạn!
Nhấp chuột vào đây để mở rộng...
Sửa thế này:
PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy
        Cls.PasteSpecial Paste:=xlValues
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("H16:M16").Copy
        Cls.PasteSpecial Paste:=xlValues
    End If
End Sub
 
Upvote 0
phulien1902 đã viết:
Sửa thế này:
PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy
        Cls.PasteSpecial Paste:=xlValues
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("H16:M16").Copy
        Cls.PasteSpecial Paste:=xlValues
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn cho hỏi thêm
Khi hiện bảng "chon o de paste" nếu chọn Cancel thì nó báo lỗi "run time error '424' object required"
Vậy có cách nào để khắc phục lỗi này được không bạn
Cảm ơn các bạn!
 
Upvote 0
hoanglocphat đã viết:
Bạn cho hỏi thêm
Khi hiện bảng "chon o de paste" nếu chọn Cancel thì nó báo lỗi "run time error '424' object required"
Vậy có cách nào để khắc phục lỗi này được không bạn
Cảm ơn các bạn!
Nhấp chuột vào đây để mở rộng...
Bạn thử:
PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        On Error GoTo Thoat
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy
        Cls.PasteSpecial Paste:=xlValues
Thoat:
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        On Error GoTo abc
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If Cls = "" Then Exit Sub
        Range("H16:M16").Copy
        Cls.PasteSpecial Paste:=xlValues
abc:
    End If
End Sub
 
Upvote 0
phulien1902 đã viết:
Bạn thử:
PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        On Error GoTo Thoat
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy
        Cls.PasteSpecial Paste:=xlValues
Thoat:
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        On Error GoTo abc
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If Cls = "" Then Exit Sub
        Range("H16:M16").Copy
        Cls.PasteSpecial Paste:=xlValues
abc:
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em chạy thử thì thấy đúng với dòng 10 nhưng lại không copy được với dòng 16
Em sửa lại thế này thì được
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range
    On Error Resume Next
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If Err.Number = 424 Then
            Exit Sub
        Else
            Range("K10:P10").Copy
            Cls.PasteSpecial Paste:=xlValues
        End If
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If Err.Number = 424 Then
            Exit Sub
        Else
            Range("H16:M16").Copy
            Cls.PasteSpecial Paste:=xlValues
        End If
    End If

End Sub
 
Upvote 0
phulien1902 đã viết:
Bạn thử:
PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        On Error GoTo Thoat
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        Range("K10:P10").Copy
        Cls.PasteSpecial Paste:=xlValues
Thoat:
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        On Error GoTo abc
        Set Cls = Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If Cls = "" Then Exit Sub
        Range("H16:M16").Copy
        Cls.PasteSpecial Paste:=xlValues
abc:
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
1 cách nữa anh ạ.
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cls As Range, MyCol As New Collection
    
    If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
        MyCol.Add Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If TypeOf MyCol(1) Is Range Then Set Cls = MyCol(1)
        
        If Cls Is Nothing Then
            Exit Sub
        Else
            Range("K10:P10").Copy
            Cls.PasteSpecial Paste:=xlValues
        End If
    ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
        MyCol.Add Application.InputBox("Chon o de Paste", "GPE", Type:=8)
        If TypeOf MyCol(1) Is Range Then Set Cls = MyCol(1)
        
        If Cls Is Nothing Then
            Exit Sub
        Else
            Range("H16:M16").Copy
            Cls.PasteSpecial Paste:=xlValues
        End If
    End If
End Sub
 
Upvote 0
Tự động chọn vùng là ý tưởng điên rồ.
Ví dụ tôi thực sự chỉ muốn 1 ô trong vùng thì làm cách nào bây giờ?
Tự động copy thì lại càng vô duyên hơn.
Cứ mỗi lần tôi đi ngang vùng thì tôi lại phải trả lời 1 khối messages.

Nếu thực sự muốn làm thì phải có một tham số điều khiển. Ví dụ có một ô nào đó (A1 chẳng hạn) chứa địa chỉ vùng ảnh hưởng. Tôi có thể dùng ô này để điều chỉnh ý mình. Nếu không muốn dùng ô thì dùng một name.
 
Upvote 0
Sao thấy code lằng nhằng quá nhỉ
Tôi viết vầy:
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim rngCopy As Object, rngPaste As Object
  If Not Intersect(Target, Range("K10:P10")) Is Nothing Then
    Set rngCopy = Range("K10:P10")
  ElseIf Not Intersect(Target, Range("H16:M16")) Is Nothing Then
    Set rngCopy = Range("H16:M16")
  End If
  If TypeName(rngCopy) = "Range" Then
    On Error Resume Next
    Set rngPaste = Application.InputBox("Chon vùng Paste", Type:=8)
    On Error GoTo 0
    If TypeName(rngPaste) = "Range" Then rngPaste.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
  End If
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Y
Lấy dữ liệu từ nhiều sheet khác nhau.
2
Trả lời
20
Đọc
563
lib.enigma
L
GPE-Trợ Lý
ĐĂNG KÍ THAM DỰ SINH NHẬT GPE TẠI HN - SỰ KIỆN TALKSHOW ĐẶC BIỆT
    • Thích
2
Trả lời
25
Đọc
1K
hoangdanh282vn
hoangdanh282vn
Nguyễn Duy Tuân
  • Dán lên cao
Sử dụng AI trong Excel với Add-in A-Tools AI v10 (2 người xem)
    • Thích
    • Cảm ơn
Trả lời
8
Đọc
870
Nguyễn Duy Tuân
Nguyễn Duy Tuân
L
xin anh chị giúp em công thức tính tổng năm theo điều kiện ạ (1 người xem)
Trả lời
8
Đọc
188
Phan Thế Hiệp
Phan Thế Hiệp
T
In lặp lại nhiều dòng ở cuối các trang
Trả lời
13
Đọc
411
Hoàng Tuấn 868
H
T
Cách cộng tổng chính xác nhất
Trả lời
6
Đọc
200
minhminh27
minhminh27
K
Tạo mã thiết bị
Trả lời
10
Đọc
263
khoailang
K
C
Xin file lên thực đơn và định lượng món ăn cho suất ăn công nghiệp
Trả lời
0
Đọc
69
Chihuong_vp90
C
T
Lỗi Khi Mở File Excel
Trả lời
3
Đọc
104
Hoàng Tuấn 868
H
H
Em chào anh chị ạ.Em cần xếp lịch nghỉ randum cho 1 số nhóm làm việc trong 1 công ty.
Trả lời
4
Đọc
143
Duy Tùng 9x
Duy Tùng 9x
1
Em hỏi chút về hàm điều kiện với liệt kê
Trả lời
2
Đọc
141
123456it
1
M
File excel ứng dụng trong nhập xuất kho, thu chi, bán hàng và công nợ (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
7 8 9
Trả lời
165
Đọc
31K
quick87
quick87
chickenexcel
xin hướng dẫn code chọn hình ảnh trong file (1 người xem)
Trả lời
2
Đọc
114
chickenexcel
chickenexcel
tramcannt
data validation
Trả lời
2
Đọc
124
ptm0412
ptm0412
giaiphap
Add-Ins cho Excel 2007 -2016 32bit và 64bit (1 người xem)
    • Thích
    • Yêu thích
    • Ngạc nhiên
24 25 26
Trả lời
514
Đọc
204K
hoangtuan.net
hoangtuan.net
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024)
    • Thích
2 3
Trả lời
56
Đọc
7K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
Lỗi syntax error
Trả lời
2
Đọc
123
ptm0412
ptm0412
H
Xin các bác giúp đỡ cách đổi thời gian thành số thập phân
Trả lời
8
Đọc
167
huyphanthieu
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (6 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
17 18 19
Trả lời
361
Đọc
40K
NGUYEN THOA 123
NGUYEN THOA 123
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
tungnguyen_kt
tungnguyen_kt
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom