Excel 在一个表中查找值，从同一行复制不同列中的数据，然后粘贴到另一个表中

所以我有两张桌子。一个表包含一大串作业/名称等，另一个表本质上是一个“作业跟踪器”，列出所有作业及其到期时间

我每个月或每个季度都必须做某些工作。在每个月初，我必须检查我存储的列表，复制所有标记为月/季度的工作，然后将它们粘贴到我的工作跟踪器中。我们每月的最低工资约为110英镑，所以我正在尝试将其自动化，因为工作信息没有任何变化——只是到期日期

我想做的是在我的表中检查标记为“每月”的任何工作，复制该行的工作名称并将其粘贴到我的工作跟踪器中

我有意使用If语句单独完成这一切，因为我将创建一个UserForm，允许我（和其他用户）选中一个框，以决定他们是否希望预订某些工作，即每月、每季度、每半年等

例如，我希望代码执行以下操作：

If Frequency In Job Table = "Monthly" Then

Copy the Job Name 

Paste the Job Name into Job Tracking table

End If

基本上会产生这种输出： 这是我目前掌握的密码。我的问题是，它只对一个结果有效，并不是每个结果都能通过

Sub Test_IF_MATCH()

Dim ProdWS As Worksheet
Dim ProdTBL As ListObject
Dim ProdVAL As ListColumn
Dim newRow As ListRow
Dim newCol As ListColumn
Dim ColNum As Long
Dim TargetTBL As ListObject
Dim TargetVAL As ListColumn
Dim TargetVAL_F As ListColumn

Dim TargetRange As Range
Dim curr As Range

Set ProdWS = ActiveWorkbook.Worksheets("TESTWS")       '#####Edit here for deployment
Set ProdTBL = ProdWS.ListObjects("TESTTBL")            '#####Edit here for deployment
Set ProdVAL = ProdTBL.ListColumns("ValToMove")         '#####Edit here for deployment
Set ProdVAL_CPY = ProdTBL.ListColumns("Frequency")     '#####Edit here for deployment

Set TargetTBL = ProdWS.ListObjects("TESTTBL2")         '#####Edit here for deployment
Set newRow = TargetTBL.ListRows.Add
Set newCol = TargetTBL.ListColumns("Frequency output") '#####Edit here for deployment
ColNum = newCol.Index


'########################## Variables ##########################'
Set TargetRange = ProdTBL.ListColumns("Frequency").DataBodyRange
FindByFrequency = "Monthly"
'###############################################################'

'############## Index match values ##############'

Dim LookUpWS As Worksheet
Dim LookupRNG As Range

Set LookUpWS = ActiveWorkbook.Worksheets("TESTWS")
Set LookupRNG = LookUpWS.ListObjects("TESTTBL").DataBodyRange

'## Match one

Dim M1_Search As Range
Dim Test_TBL As ListObject

Set Test_TBL = LookUpWS.ListObjects("TESTTBL")
Set M1_Search = Test_TBL.ListColumns("Frequency").DataBodyRange

MatchOne = Application.WorksheetFunction.Match(FindByFrequency, M1_Search, 0)

'## Match two

Dim M2_Search As Range
Set M2_Search = LookUpWS.Range("A1:C1")

MatchTwo = Application.WorksheetFunction.Match("Job name", M2_Search, 0)

'################################################'

For Each curr In TargetRange

    If curr.Value = FindByFrequency Then
        Result = Application.WorksheetFunction.Index(LookupRNG, MatchOne, MatchTwo)
            With newRow
                .Range(, ColNum) = Result
            End With
    End If

Next

End Sub

---

有人能帮忙吗？我现在对此束手无策，已经用尽了我的能力来谷歌和试错这个问题

下面是一个使用过滤器从频率列=每月的表中获取所有实例的示例：

Sub tgr()

    Dim wsData As Worksheet
    Dim oData As ListObject
    Dim rMatch As Range
    Dim FindByFrequency As String
    Dim FilterCol As String

    Set wsData = ActiveWorkbook.Worksheets("TESTWS")
    Set oData = wsData.ListObjects("TESTTBL")
    FindByFrequency = "Monthly"
    FilterCol = "Frequency"

    With oData.Range
        .AutoFilter oData.ListColumns(FilterCol).Index, FindByFrequency, xlFilterValues
        On Error Resume Next    'Prevent error if no cells are found
        Set rMatch = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0         'Remove On Error Resume Next condition
        .AutoFilter
    End With

    If Not rMatch Is Nothing Then
        rMatch.Copy
        wsData.Range("D2").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If

End Sub

---

下面是一个使用过滤器从频率列=每月的表中获取所有实例的示例：

Sub tgr()

    Dim wsData As Worksheet
    Dim oData As ListObject
    Dim rMatch As Range
    Dim FindByFrequency As String
    Dim FilterCol As String

    Set wsData = ActiveWorkbook.Worksheets("TESTWS")
    Set oData = wsData.ListObjects("TESTTBL")
    FindByFrequency = "Monthly"
    FilterCol = "Frequency"

    With oData.Range
        .AutoFilter oData.ListColumns(FilterCol).Index, FindByFrequency, xlFilterValues
        On Error Resume Next    'Prevent error if no cells are found
        Set rMatch = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0         'Remove On Error Resume Next condition
        .AutoFilter
    End With

    If Not rMatch Is Nothing Then
        rMatch.Copy
        wsData.Range("D2").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If

End Sub

---

因此，根据Tigeravatar的回答，我设法调整代码以满足我的需要

几乎就要到了，非常非常感谢Tigeravatar抽出时间，非常感谢。有时候我们只需要用新的眼光来看待问题来克服它，嗯

下面是我使用的代码。现在，它只复制目标作业名称（而不是整个表），并通过添加新行将其粘贴到新表中

我添加了一些注释来解释我所做的事情，以防这对其他人有所帮助

Sub tgr()

Dim wsData As Worksheet
Dim oData As ListObject
Dim oTarget As ListObject
Dim rMatch As Range
Dim FindByFrequency As String
Dim FilterCol As String
Dim newRow As ListRow
Dim colIndex As Integer
Dim colName As ListColumn

Set wsData = ActiveWorkbook.Worksheets("Test")

'The source of all the main data to pull from.
Set oData = wsData.ListObjects("PRODUCT")

'Gets the column index number of the column name that we want a result from
Set colName = oData.ListColumns("Job name")
colIndex = colName.Index

'Sets the destination for the data
Set oTarget = wsData.ListObjects("TRACKER")

'Adds a new row to the destination table
Set newRow = oTarget.ListRows.Add(AlwaysInsert:=True)

'############### Variable here ###############'
FindByFrequency = "Monthly"
'#############################################'

FilterCol = "Frequency"

'Copies the data that matches the criteria
With oData.Range
    .AutoFilter oData.ListColumns(FilterCol).Index, FindByFrequency, xlFilterValues
    On Error Resume Next    'Prevent error if no cells are found
    Set rMatch = .Offset(1).Resize(.Rows.Count - 1, colIndex).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0         'Remove On Error Resume Next condition
    .AutoFilter
End With

'Debug - not essential
Debug.Print "Add " & rMatch.Count & " rows"

'Starts to paste the values to destination
If Not rMatch Is Nothing Then
    rMatch.Copy
    'Creates a new row for each values copied and pastes as values to destination
    newRow.Range.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End If


End Sub

---

因此，根据Tigeravatar的回答，我设法调整代码以满足我的需要

几乎就要到了，非常非常感谢Tigeravatar抽出时间，非常感谢。有时候我们只需要用新的眼光来看待问题来克服它，嗯

下面是我使用的代码。现在，它只复制目标作业名称（而不是整个表），并通过添加新行将其粘贴到新表中

我添加了一些注释来解释我所做的事情，以防这对其他人有所帮助

Sub tgr()

Dim wsData As Worksheet
Dim oData As ListObject
Dim oTarget As ListObject
Dim rMatch As Range
Dim FindByFrequency As String
Dim FilterCol As String
Dim newRow As ListRow
Dim colIndex As Integer
Dim colName As ListColumn

Set wsData = ActiveWorkbook.Worksheets("Test")

'The source of all the main data to pull from.
Set oData = wsData.ListObjects("PRODUCT")

'Gets the column index number of the column name that we want a result from
Set colName = oData.ListColumns("Job name")
colIndex = colName.Index

'Sets the destination for the data
Set oTarget = wsData.ListObjects("TRACKER")

'Adds a new row to the destination table
Set newRow = oTarget.ListRows.Add(AlwaysInsert:=True)

'############### Variable here ###############'
FindByFrequency = "Monthly"
'#############################################'

FilterCol = "Frequency"

'Copies the data that matches the criteria
With oData.Range
    .AutoFilter oData.ListColumns(FilterCol).Index, FindByFrequency, xlFilterValues
    On Error Resume Next    'Prevent error if no cells are found
    Set rMatch = .Offset(1).Resize(.Rows.Count - 1, colIndex).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0         'Remove On Error Resume Next condition
    .AutoFilter
End With

'Debug - not essential
Debug.Print "Add " & rMatch.Count & " rows"

'Starts to paste the values to destination
If Not rMatch Is Nothing Then
    rMatch.Copy
    'Creates a new row for each values copied and pastes as values to destination
    newRow.Range.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End If


End Sub

---

你好。非常感谢您的帮助，非常感谢您处理问题的方式-我没有想到这一点！很遗憾，我不知道我在自我介绍中是否解释得足够好，所以我为浪费您的时间向您道歉。宏只需要复制相应的单元格（我只需将列号添加到Set rMatch..line中即可轻松解决此问题。但是，我的问题是将这些值粘贴到新表中。我似乎无法让它添加正确数量的行，然后粘贴数据。我可以让它生成一行，但不是所需的行数。非常感谢您的帮助，非常感谢您的帮助接近问题-我没有想到这一点！很遗憾，我不知道我在介绍中对自己的解释是否足够好，因此我对您浪费的时间表示歉意。宏只需要复制相应的单元格（我只需将列号添加到Set rMatch..line中即可轻松解决此问题。但是，我的问题是将这些值粘贴到新表中。我似乎无法让它添加正确数量的行，然后粘贴数据。我可以让它生成一行，但不是所需数量