Блог

Итак, у меня есть две таблицы. Одна таблица содержит большой список заданий / имен и т.д., А другая таблица, по сути, представляет собой «отслеживание заданий», в котором перечислены все задания и сроки их выполнения.

У меня есть определенные задания, которые я должен выполнять каждый месяц или квартал. В начале каждого месяца я должен просмотреть свой сохраненный список, скопировать все задания, помеченные как месяц / квартал, а затем вставить их в мой журнал отслеживания заданий. Минимум у нас около 110 в месяц, поэтому я пытаюсь автоматизировать это, поскольку в информации о задании ничего не меняется — только срок выполнения.

Что я хочу сделать, это проверить в моей таблице наличие любого задания, помеченного как «Ежемесячное», скопировать название задания из этой строки и вставить его в мой журнал отслеживания заданий.

Я намеренно делаю все это отдельно, используя инструкции If, поскольку я создам пользовательскую форму, которая позволит мне (и другим пользователям) установить флажок, чтобы решить, хотят ли они бронировать определенные задания, т. Е. Ежемесячно, ежеквартально, раз в два года и т.д.

Например, я хочу, чтобы код выполнял следующее:

 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
  

Кто-нибудь может помочь, пожалуйста? На этом мои размышления заканчиваются, и я исчерпал свои возможности в Google и методом проб / ошибок решил проблему!

Вот пример использования фильтра для захвата всех экземпляров из вашей таблицы, где столбец частоты = Ежемесячно:

 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 " amp; rMatch.Count amp; " 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