excel - 需要根据所选的下拉菜单将新信息复制到其他两个工作表之一

Question

我有 3 个工作表，由 3 个不同的人使用。如果选择了“Res”，“Builder Contact”工作表需要输入到“Res Jobs”工作表中；如果选择了“Comm”，则需要输入到“Comm Jobs”工作表中。正在复制的信息不会复制到同一列(例如，“Builder Contact”第 1、10、2、4、5 列将分别是“Res Jobs”第 1、2、3、7、8 列)。

当从“Builder Contact”表的下拉菜单中选择“Res”或“Comm”时，我还需要自动更新此信息。我当前的代码目前可以做到这一点，但我每次都必须点击运行，并且由于循环，它会重复所有内容。但循环是我当前获取“x”值的方式，我需要找到复制所有信息的行。

Sub Res_Comm()
    Sheets("Builder Contact").Select
    ' Find the last row of data
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    ' Loop through each row
    For x = 2 To FinalRow
        ' Decide if to copy based on column K (column with the drop down menu to select "Res" or "Comm")
        ThisValue = Cells(x, 11).Value
        If ThisValue = "Res" Then
            Cells(x, 1).Copy
            Sheets("Res Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 10).Copy
            Sheets("Res Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 2).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 2).Copy
            Sheets("Res Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 3).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 4).Copy
            Sheets("Res Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 7).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 5).Copy
            Sheets("Res Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 8).Select
            ActiveSheet.Paste
            ' This column is asking for the source, which in this case would be the name of the user for "Builder Contact"
            Cells(NextRow, 6).Value = "Dan"
            
            
            
        ElseIf ThisValue = "Comm" Then
            Cells(x, 1).Copy
            Sheets("Comm Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 10).Copy
            Sheets("Comm Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 3).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 2).Copy
            Sheets("Comm Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 4).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 4).Copy
            Sheets("Comm Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 8).Select
            ActiveSheet.Paste
            Sheets("Builder Contact").Select
            
            Cells(x, 5).Copy
            Sheets("Comm Jobs").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(NextRow, 9).Select
            ActiveSheet.Paste
            
            Cells(NextRow, 7).Value = "Dan"
        End If
    Next x
End Sub

[建筑商联系方式][1][Res Jobs][2]

它还不允许我直接添加照片，但希望链接能够正常工作。 [1]:/image/ynDvD.png [2]:/image/1bokm.png

Answer 1

看起来好像您的用户在 K 列中输入了“Res”或“Comm”。下面的代码应将“Builder Contact”表的相应列中的值写入“Res Jobs”表的相应列中或“通讯工作”。您需要将此代码放入“Builder Contact”表的模块中。为此，请双击“Microsoft Excel 对象”下的“Builder 联系人”，如下所示。

然后粘贴此代码:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim s As Worksheet
    Dim source_columns As Variant
    Dim dest_columns As Variant
    Dim next_row As Long
    Dim x As Long
    
    If Target.Column = 11 Then
        If Target.Value = "Res" Then
            Set s = Sheets("Res Jobs")
            dest_columns = Array(1, 2, 3, 7, 8)
        ElseIf Target.Value = "Comm" Then
            Set s = Sheets("Comm Jobs")
            dest_columns = Array(1, 3, 4, 8, 9)
        Else
            Exit Sub
        End If
        
        source_columns = Array(1, 10, 2, 4, 5)
        
        next_row = s.Cells(s.Rows.Count, 1).End(xlUp).Row + 1
        
        For x = 0 To UBound(source_columns)
             s.Cells(next_row, dest_columns(x)).Value = Cells(Target.Row, source_columns(x))
        Next

        s.Cells(next_row, 6).Value = "Dan"
        
    End If

End Sub