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

G
  • Question Question
hỏi về cách tiếp cận, gán dữ liệu với các Control không tên ( UserForm ) (4 người xem)
Trả lời
3
Đọc
57
thuytrangbp28
T
Đ
  • Question Question
Chuyển đổi dữ liệu thô về dạng bảng (Table) (2 người xem)
Trả lời
2
Đọc
319
HUONGHCKT
H
D
Nhờ các A/C trợ giúp căng quá ạ (3 người xem)
Trả lời
1
Đọc
35
minhminh27
minhminh27
ankhanh2k2
sắp xếp dữ liệu chấm công (2 người xem)
    • Buồn
Trả lời
7
Đọc
145
VetMini
V
N
  • Question Question
Nhờ mọi người giúp em kiểm tra dữ liệu không đúng định dạng từ sheet ban đầu ạ (1 người xem)
Trả lời
5
Đọc
52
thuytrangbp28
T
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
261
Đọc
27K
ciaoceo
C
Maika8008
  • Đã giải quyết
[Chia sẻ] Dùng VBA trộn dữ liệu Excel sang file Word mẫu (tương tự chức năng Mail Merge) (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
25 26 27
Trả lời
524
Đọc
50K
quyenpv
quyenpv
tranaidh
Giúp sắp xếp phòng thi tốt nghiệp năm 2025 (1 người xem)
Trả lời
1
Đọc
92
tranaidh
tranaidh
H
Không hiển thị hết kí tự khi dùng mail merge
Trả lời
19
Đọc
31K
nghiahandsome1995
nghiahandsome1995
nghiahandsome1995
  • Question Question
in đậm chuỗi văn bản bằng excel
Trả lời
8
Đọc
213
nghiahandsome1995
nghiahandsome1995
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
Trả lời
2
Đọc
133
PhanTuHuong
PhanTuHuong
Đỗ Tú Anh
♪♫♪ ~ Thư Giãn Với Âm Nhạc ~ ♫♪♫
    • Thích
21 22 23
Trả lời
447
Đọc
11K
Đỗ Tú Anh
Đỗ Tú Anh
S
  • Question Question
Nhờ Mọi người giúp đỡ gộp nhiều dòng thành 1 dòng nhiều cột trong Power Query. (1 người xem)
Trả lời
3
Đọc
150
DeTong
D
dangvandang
  • Question Question
Chia sẻ tích hợp trí tuệ nhân tạo (AI) vào excel
    • Thích
Trả lời
8
Đọc
2K
dangvandang
dangvandang
HeSanbi
  • Question Question
Công cụ tạo và chỉnh sửa Ribbon ngay trên Excel (Bản Việt hóa) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
10
Đọc
6K
HeSanbi
HeSanbi
N
  • Question Question
Xin code link dữ liệu VBA ạ ! (1 người xem)
Trả lời
1
Đọc
105
BuiQuangThuan
B
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
7
Đọc
504
trung_bhxh
T
toanthinh
Công thức tính tuổi âm lịch
Trả lời
3
Đọc
129
toanthinh
toanthinh
S
Cần hỗ trợ xử lý hiện ngày sản phẩm bằng VBA
Trả lời
0
Đọc
73
sonminhtran
S
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
2
Đọc
853
GPE-Trợ Lý
GPE-Trợ Lý
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW EXCEL TRONG SẢN XUẤT
Back
Top Bottom