VBA将Sheet 1列匹配到Sheet 2列

工作表1有AT列。 工作表1的某些列有公式，而其他列则有一个下拉列表。 工作表2有列AP。 我希望能够将Sheet 1数据粘贴到Sheet 2中 – 由公式和下拉菜单生成的数据。 另外在某种意义上说，如果我改变表1中的任何内容，它就会在另一张表上发生变化。 我想能够做到这一点的多个列。 事情是Sheet 1和Sheet 2列彼此不是真的。 我的意思是表1中的A列是表2中的C列等。

现在，我只是简单地使用两张纸上的公式来使这个工作。 我不想这样继续下去。 macros观会更好。

谢谢！ 请帮忙。

Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range, Rc As Range, R As Long Dim hC As String, Lr As Long Dim Ws2 As Worksheet On Error GoTo mExit Set Ws2 = Worksheets("Sheet 2") hC = "AO" Application.EnableEvents = False Set Rng = Application.Intersect(Target, Columns("A:T")) If Not Rng Is Nothing Then For Each Rc In Rng.Rows R = Rc.Row If Range(hC & R).HasFormula Then Lr = Ws2.Range(Range(hC & R).Formula).Row Else With Ws2 Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1 Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr End With End If With Ws2 .Range("B" & Lr).Value = Range("A" & R).Value .Range("C" & Lr).Value = Range("C" & R).Value .Range("D" & Lr).Value = Range("D" & R).Value .Range("E" & Lr).Value = Range("E" & R).Value .Range("F" & Lr).Value = Range("F" & R).Value .Range("G" & Lr).Value = Range("G" & R).Value .Range("H" & Lr).Value = Range("H" & R).Value .Range("I" & Lr).Value = Range("I" & R).Value .Range("J" & Lr).Value = Range("J" & R).Value .Range("K" & Lr).Value = Range("AH" & R).Value .Range("L" & Lr).Value = Range("K" & R).Value .Range("M" & Lr).Value = Range("L" & R).Value .Range("N" & Lr).Value = Range("M" & R).Value .Range("O" & Lr).Value = Range("N" & R).Value .Range("P" & Lr).Value = Range("AA" & R).Value .Range(hC & Lr).Value = "Related" End With Next End If mExit: Application.EnableEvents = True End Sub 

编辑代码（3_31_3017）

 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range, Rc As Range, R As Long Dim hC As String, Lr As Long Dim Ws2 As Worksheet On Error GoTo mExit Set Ws2 = Worksheets("Route_Sheet") hC = "AP" Application.EnableEvents = False Set Rng = Application.Intersect(Target, Columns("A:AL")) If Not Rng Is Nothing Then For Each Rc In Rng.Rows R = Rc.Row If Range(hC & R).HasFormula Then Lr = Ws2.Range(Range(hC & R).Formula).Row Else With Ws2 Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1 Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr End With End If With Ws2 .Range("B" & Lr).Value = Range("A" & R).Value .Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value .Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value .Range("K" & Lr).Value = Range("AH" & R).Value .Range("P" & Lr).Value = Range("AA" & R).Value .Range("Q" & Lr).Value = Range("U" & R).Value .Range(hC & Lr).Value = "Related" End With Next End If mExit: Application.EnableEvents = True End Sub 

Answer 1

我们至less需要知道一件事情，即Sheet 1中的row(y)与Sheet 2 row(y)有关。 这可以通过为每行添加唯一的标识符作为@tigeravatar提到，或者通过在Sheet 1与row(y)相关的row(x)中未使用的列中添加一个公式来实现。

在Sheet 1模块中添加：

 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range, Rc As Range, R As Long Dim hC As String, Lr As Long Dim Ws2 As Worksheet On Error GoTo mExit Set Ws2 = Worksheets("Sheet 2") hC = "U" 'Change this to any unused column and You can hide it Application.EnableEvents = False Set Rng = Application.Intersect(Target, Columns("A:T")) If Not Rng Is Nothing Then For Each Rc In Rng.Rows R = Rc.Row If Range(hC & R).HasFormula Then Lr = Ws2.Range(Range(hC & R).Formula).Row Else With Ws2 Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1 Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr End With End If With Ws2 ' Add here all columns you need like : '===================================== .Range("C" & Lr).Value = Range("A" & R).Value .Range("A" & Lr).Value = Range("B" & R).Value '...etc '===================================== .Range(hC & Lr).Value = "Related" End With Next End If mExit: Application.EnableEvents = True End Sub 

编辑：
右键单击“主”工作表选项卡并selectView Code ，并将其中粘贴此代码：

 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range, Rc As Range, R As Long Dim hC As String, Lr As Long Dim Ws2 As Worksheet On Error GoTo mExit Set Ws2 = Worksheets("Sheet 2") 'Change "Sheet 2" to your target sheet name like "Route_Sheet" or "Lists" hC = "AO" Application.EnableEvents = False Set Rng = Application.Intersect(Target, Columns("A:AH")) If Not Rng Is Nothing Then For Each Rc In Rng.Rows R = Rc.Row If Range(hC & R).HasFormula Then Lr = Ws2.Range(Range(hC & R).Formula).Row Else With Ws2 Lr = .Range(hC & .Rows.Count).End(xlUp).Row If Not (Lr = 1 And .Range(hC & Lr).Value = vbNullString) Then Lr = Lr + 1 Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr End With End If With Ws2 .Range("B" & Lr).Value = Range("A" & R).Value .Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value .Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value .Range("K" & Lr).Value = Range("AH" & R).Value .Range("P" & Lr).Value = Range("AA" & R).Value .Range(hC & Lr).Value = "Related" End With Next End If mExit: Application.EnableEvents = True End Sub 

这是一个工作表事件，当用户更改列中的任何单元格（“A：AH”）时，该事件将自动运行。

如果你想手动运行，你可以在Module1添加新的sub：

 Sub Test() With sheets("Master").Range("A2:A50") ' change this range to all rows you need like "A5:A100" .Value = .Value End With End Sub 

要么：

 Sub Test() With Sheets("Master") Application.Run .CodeName & ".Worksheet_Change", .Range("A1:A50") 'change this range to all rows you need like "A5:A100" End With End Sub