Question

表单1包含A-T列。工作表1的某些列具有公式，其他列具有下拉列表。片材2具有列A-P。我希望能够在Sheet 2中粘贴Sheet 1数据 - 由于公式和下拉而生成的数据。另外在某种程度上，如果我更改了Sheet 1中的任何内容，它将在另一张纸上更改。我希望能够为多个列执行此操作。问题是Sheet 1和Sheet 2列彼此不相符。我的意思是表1中的A列是表2中的C列等。

现在，我已经在两张纸上使用公式简化了单元格以使其工作。我不希望以这种方式继续下去。宏会更好。

谢谢！请帮忙。

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

至少有一件事要知道row(x)中的Sheet 1与row(y)中的Sheet 2有关。这可以通过在@tigeravatar中添加每行的唯一标识符来完成，也可以在row(x) Sheet 1中与row(y) Sheet 2相关的未使用的列中添加一个公式。< / p>

在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

修改
右键单击“主”表单选项卡，然后选择View 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 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

用于将Sheet 1列与Sheet 2列匹配的VBA

1 个答案: