Question

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

我每个月或每个季度必须完成某些工作。在每个月初，我必须浏览存储的列表，复制所有标记为月/季度的作业，然后将其粘贴到我的作业跟踪器中。我们每个月的最低时间约为110，因此我正在尝试使其自动化，因为职位信息没有任何变化-只是截止日期。

我要做的是在表中检查所有标记为“每月”的作业，复制该行的作业名称并将其粘贴到我的作业跟踪器中。

我打算使用If语句分别完成所有操作，因为我将创建一个UserForm，该表单允许我（和其他用户）选中一个框来决定他们是否要预定某些工作，例如每月，每季度，每半年等等

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

If Frequency In Job Table = "Monthly" Then

Copy the Job Name 

Paste the Job Name into Job Tracking table

End If

本质上将创建以下输出： Ideal result 这是到目前为止的代码。我的问题是，它仅适用于一个结果，而不能通过每个结果。

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

有人可以帮助吗？我的智慧到此为止，并达到了我使用Google的能力并尝试/解决问题！

Answer 1

这里是一个示例，该示例使用过滤器从“频率”列=“每月”中获取表中的所有实例：

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

Answer 2

因此，根据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

在一个表中找到一个值，将数据复制到同一行的另一列中，然后粘贴到另一张表中

2 个答案: