VBA để liên kết được hai hoặc nhiều ô theo 2 chiều (1 người xem)

  • Thread starter Thread starter hktanh
  • Ngày gửi Ngày gửi
Liên hệ QC

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

hktanh

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
22/8/19
Bài viết
112
Được thích
8
Giới tính
Nam
mọi người cho mình hỏi làm có thể dùng đoạn code nào để làm được công việc sau không nhỉ. Mình muốn tạo code VBA để nếu nhập giá trị vào ô A1 của Sheet1 thì ô A1 của Sheet2 cũng tự động nhảy giá trị đó Và Ngược Lại, hoặc nếu liên kết được nhiều ô trong Excel như thế này thì càng tốt, với lại mình cần thao tác bằng nhau này phải thực hiện được liên tục, tức là bất kể khi nào mình thay đổi giá trị ô A1 của Sheet1 hoặc Sheet2 và thay đổi bao nhiêu lần, không cần phải ấn nút lệnh thì hai ô A1 của hai sheet kia đều tự nhảy bằng nhau. Mình cảm ơn
 
mọi người cho mình hỏi làm có thể dùng đoạn code nào để làm được công việc sau không nhỉ. Mình muốn tạo code VBA để nếu nhập giá trị vào ô A1 của Sheet1 thì ô A1 của Sheet2 cũng tự động nhảy giá trị đó Và Ngược Lại, hoặc nếu liên kết được nhiều ô trong Excel như thế này thì càng tốt, với lại mình cần thao tác bằng nhau này phải thực hiện được liên tục, tức là bất kể khi nào mình thay đổi giá trị ô A1 của Sheet1 hoặc Sheet2 và thay đổi bao nhiêu lần, không cần phải ấn nút lệnh thì hai ô A1 của hai sheet kia đều tự nhảy bằng nhau. Mình cảm ơn
Di chuột vào sheet tab "Sheet1", chọn view code, dán đoạn code dưới đây
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Worksheet.Name = ActiveSheet.Name Then
    If Target.Address = "$A$1" Then Sheet2.Range("A1") = Target
End If
End Sub
Sheet2 làm tương tự, dán đoạn code dưới đây
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Worksheet.Name = ActiveSheet.Name Then
    If Target.Address = "$A$1" Then Sheet1.Range("A1") = Target
End If
End Sub
 
Upvote 0
Di chuột vào sheet tab "Sheet1", chọn view code, dán đoạn code dưới đây
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Worksheet.Name = ActiveSheet.Name Then
    If Target.Address = "$A$1" Then Sheet2.Range("A1") = Target
End If
End Sub
Sheet2 làm tương tự, dán đoạn code dưới đây
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Worksheet.Name = ActiveSheet.Name Then
    If Target.Address = "$A$1" Then Sheet1.Range("A1") = Target
End If
End Sub
bạn ơi thế nếu mình muốn liên kết ô A1 của 4 sheet khác nhau với yêu cầu như trên thì làm thế nào nhỉ :")) Mình đã test thử mã của bạn và dùng rất tốt rồi nhé :"))
 
Upvote 0
Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
bạn ơi thế nếu mình muốn liên kết ô A1 của 4 sheet khác nhau với yêu cầu như trên thì làm thế nào nhỉ :")) Mình đã test thử mã của bạn và dùng rất tốt rồi nhé :"))
Nhấn alt+F11
Kích đúp vào ThisWorkbook, dán đoạn code dưới đây vào.
Địa chỉ ô liên kết có thể thay đổi theo biến Address0
Tên sheet liên kết có thể thay đổi trong mảng Arr0
Mã:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Arr0
Dim Name0
Dim Address0
Arr0 = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
Address0 = "$A$1"
If Sh.Name = ActiveSheet.Name Then
    If Target.Address = Address0 Then
        For Each Name0 In Arr0
            If Name0 <> Sh.Name Then
                Sheets(Name0).Range(Address0) = Target
            End If
        Next Name0
    End If
End If
End Sub
 
Upvote 0
Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
mình chưa hiểu lắm nhưng mình sẽ nghiên cứu nhé
Bài đã được tự động gộp:

Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
Mình thử được rồi bạn nhé, cảm ơn bạn :sweatdrop: ||\ Mình thấy cái hay của bạn ở chỗ các ô của sheet không nhất thiết phải giống nhau :"))
 
Lần chỉnh sửa cuối:
Upvote 0
Nhấn alt+F11
Kích đúp vào ThisWorkbook, dán đoạn code dưới đây vào.
Địa chỉ ô liên kết có thể thay đổi theo biến Address0
Tên sheet liên kết có thể thay đổi trong mảng Arr0
Mã:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Arr0
Dim Name0
Dim Address0
Arr0 = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
Address0 = "$A$1"
If Sh.Name = ActiveSheet.Name Then
    If Target.Address = Address0 Then
        For Each Name0 In Arr0
            If Name0 <> Sh.Name Then
                Sheets(Name0).Range(Address0) = Target
            End If
        Next Name0
    End If
End If
End Sub
bạn ơi thế nếu ô liên kết của các sheet khác nhau không bắt buộc tất cả phải là A1 mà là các ô bất kỳ của sheet chẳng hạn sheet 1 là A1 , sheet 2 là A2 , sheet 3 là A3 thì mình làm thế nào nhỉ :sweatdrop: ||\
 
Upvote 0
Thì mình cho cái file lên cho nó nhanh nhé
bạn cho file lên đi nhé, hì hì ^^ Ví dụ mình muốn liên kết theo 2 chiều với các ô A1 của Sheet 1, A2 của Sheet 2, A3 của sheet 3, A4 cua
Thì mình cho cái file lên cho nó nhanh nhé
ok bạn nhé, bạn up file lên đi ^^ . Yêu cầu là như thế này bạn nhé: Liên kết giữa các ô bất kỳ trong các sheet, nếu liên kết được theo vùng thì rất tốt bạn nhé. Ví dụ liên kết theo 2 chiều giữa các ô A1 của Sheet 1, A2 vủa Sheet 2, A3 của Sheet 3, A4 của Sheet 4, hoặc nếu liên kết được vùng bất kỳ chẳng hạn A1:B2 của sheet 1, A2:B3 của sheet 2, A3:B4 của sheet 3, A4:B5 của sheet 4 thì rất tốt bạn nhé ^^ . Mình muốn tham khảo được nhiều cách bạn ạ, hì hì
Bài đã được tự động gộp:

Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
Cách của bạn hoạt động rất tốt nhé, mình sẽ lưu lại, có gì thắc mắc mình hỏi bạn nhé, mong bạn trả lời :")) không phải là đồ ăn giao tận miệng mình mới ăn, tại mình chưa hiểu thôi :sweatdrop:
 
Upvote 0
bạn cho file lên đi nhé, hì hì ^^ Ví dụ mình muốn liên kết theo 2 chiều với các ô A1 của Sheet 1, A2 của Sheet 2, A3 của sheet 3, A4 cua

ok bạn nhé, bạn up file lên đi ^^ . Yêu cầu là như thế này bạn nhé: Liên kết giữa các ô bất kỳ trong các sheet, nếu liên kết được theo vùng thì rất tốt bạn nhé. Ví dụ liên kết theo 2 chiều giữa các ô A1 của Sheet 1, A2 vủa Sheet 2, A3 của Sheet 3, A4 của Sheet 4, hoặc nếu liên kết được vùng bất kỳ chẳng hạn A1:B2 của sheet 1, A2:B3 của sheet 2, A3:B4 của sheet 3, A4:B5 của sheet 4 thì rất tốt bạn nhé ^^ . Mình muốn tham khảo được nhiều cách bạn ạ, hì hì
Bài đã được tự động gộp:


Cách của bạn hoạt động rất tốt nhé, mình sẽ lưu lại, có gì thắc mắc mình hỏi bạn nhé, mong bạn trả lời :")) không phải là đồ ăn giao tận miệng mình mới ăn, tại mình chưa hiểu thôi :sweatdrop:
Thông thường, nếu tôi lập file thì người yêu cầu phải trả tiền bạn ạ.
Chờ thành viên khác hỗ trợ nhé bạn.
 
Upvote 0
Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
Bạn ơi nếu bây giờ mình muốn tạo ra các cặp ô liên kết theo từng nhóm riêng biệt, ví dụ Nhóm 1 gồm có tại Sheet 1: ô A1 , A2 , tại Sheet 2: ô A3 , A4 , tại Sheet 3: ô A5 , A6. Nhóm 2 gồm có tại Sheet 1: ô B1 , B2 , tại Sheet 2: ô B3 , B4 , tại Sheet 3: ô B5 , B6 và hai nhóm 1 và 2 này là độc lập với nhau thì mình làm thế nào bạn nhỉ :hi1:
 
Upvote 0
Bạn copy đoạn này vào code của Workbook (khác code Worksheet)
Muốn bao nhiêu range thì bạn cứ sửa Dim Rs(3) As Range, 4,5 ,... tùy ý

Thậm chí bạn có thể thay đổi cả một mảng bằng cách sửa tham số thứ 2 thành True
Và thay đổi các thành phần trong mảng Rs thành mảng

JavaScript:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.EnableEvents = False
  On Error Resume Next
  Dim Rs(3) As Range
  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1")
  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("A1")
  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("A1")
  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("A1")
  Call MultiChangeCells(Target, False, Rs)
'  Set Rs(0) = ThisWorkbook.Worksheets("Sheet1").Range("A1:B1")
'  Set Rs(1) = ThisWorkbook.Worksheets(2).Range("B1:C1")
'  Set Rs(2) = ThisWorkbook.Worksheets(3).Range("C1:D1")
'  Set Rs(3) = ThisWorkbook.Worksheets(4).Range("D1:E1")
'  Call MultiChangeCells(Target, True, Rs)
  Erase Rs
  On Error GoTo 0
  Application.EnableEvents = True
End Sub

Private Sub MultiChangeCells(ByVal Target As Range, ByVal D2 As Boolean, Ranges() As Range)
  Dim Rng
  On Error Resume Next
  For Each Rng In Ranges
    If Not D2 Then Set Rng = Rng(1, 1)
    If Target.Parent.Name = Rng.Parent.Name Then
      If Rng.Address = Target.Address Then _
        GoSub ChangeValue: Exit For
    End If
  Next Rng
  Set Rng = Nothing
  On Error GoTo 0
Exit Sub:
ChangeValue:
  For Each Rng In Ranges:
    If Not D2 Then Set Rng = Rng(1, 1)
    Rng.Value = Target.Value
  Next Rng
Return
End Sub
Bạn ơi cho mình hỏi nếu trong trường hợp mình có 2 hoặc 3 nhóm vùng độc lập, mình lấy ví dụ 2 nhóm vùng độc lập, Nhóm vùng 1: ở sheet 1 là A1:B1 ; sheet 2: B1:C1 ; sheet 3: C1:"D1 ; Nhóm vùng 2: ở sheet 1 là A2:B2 ; sheet 2: B2:C2 ; sheet 3: C2:"D2 sao cho sự thay đổi các giá trị ở mỗi nhóm vùng là bằng nhau và 2 nhóm vùng này là độc lập với nhau thì mình làm thế nào bạn nhỉ, bạn chỉ cho mình cách làm từ 3 nhóm vùng trở lên và từ 4 sheet trở lên thì càng tốt nhé :"))
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Web KT

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

Back
Top Bottom