Если операторы возвращают слишком много значений

Question

Новое в VBA

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

Однако, когда я выбираю определенные поля со списком, должно быть некоторое наложение, и я получаю слишком много значений.Любые мысли или помощь с благодарностью.

Sub tblcopypast()

Dim Month As String
Dim tbl As ListObject
Dim iCt As Integer
Dim jCt As Integer
Dim lastrow As Integer
Dim targetRange As Range
Dim actRange As Range
Dim Year As String
Dim Certs As String

Worksheets("Search").Range("Newrng").ClearContents

    Set tbl = Sheet1.ListObjects("Table1")
    Month = Worksheets("Search").Month
    Year = Worksheets("Search").Year
    Certs = Worksheets("Search").cbCerts
    lastrow = tbl.ListRows.Count
    jCt = 0

    Set targetRange = Worksheets("Search").Range("newrng").End(xlUp).Offset(1, 0)

    For iCt = 1 To lastrow
        If tbl.DataBodyRange(iCt, 3) = Month And tbl.DataBodyRange(iCt, 2) = Certs And tbl.DataBodyRange(iCt, 4) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 6) = Month And tbl.DataBodyRange(iCt, 5) = Certs And tbl.DataBodyRange(iCt, 7) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 8) = Certs And tbl.DataBodyRange(iCt, 9) = Month And tbl.DataBodyRange(iCt, 10) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 3) = Month And tbl.DataBodyRange(iCt, 4) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 6) = Month And tbl.DataBodyRange(iCt, 7) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 9) = Month And tbl.DataBodyRange(iCt, 10) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 2) = Certs And tbl.DataBodyRange(iCt, 4) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 5) = Certs And tbl.DataBodyRange(iCt, 7) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
        If tbl.DataBodyRange(iCt, 8) = Certs And tbl.DataBodyRange(iCt, 10) = Year Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
    Next

    Range("Newrng").HorizontalAlignment = xlCenter
    Range("Newrng").VerticalAlignment = xlBottom
    Worksheets("Search").Columns("F:P").AutoFit


    Worksheets("Search").Month.Value = Null
    Worksheets("Search").Year.Value = Null
    Worksheets("Search").cbCerts.Value = Null


End Sub

Answer 1

Не проверено, но это может сделать то, что вам нужно.Он только проверяет совпадение, если выбрано значение для поиска.

Sub tblcopypast()

Dim Month As String
Dim tbl As ListObject
Dim iCt As Long
Dim jCt As Long
Dim lastrow As Long
Dim targetRange As Range
Dim actRange As Range
Dim Year As String
Dim Certs As String
Dim c As Long, rYear, rMonth, rCert

    Worksheets("Search").Range("Newrng").ClearContents

    Set tbl = Sheet1.ListObjects("Table1")
    Month = Worksheets("Search").Month
    Year = Worksheets("Search").Year
    Certs = Worksheets("Search").cbCerts
    lastrow = tbl.ListRows.Count
    jCt = 0

    Set targetRange = Worksheets("Search").Range("newrng").End(xlUp).Offset(1, 0)

    For iCt = 1 To lastrow

        For c = 0 To 6 Step 3 '<< use a loop to go over the row

            rYear = tbl.DataBodyRange(iCt, 4 + c)
            rMonth = tbl.DataBodyRange(iCt, 3 + c)
            rCert = tbl.DataBodyRange(iCt, 2 + c)

            If (Month = "" Or rMonth = Month) And _
               (Certs = "" Or rCert = Certs) And _
               (Year = "" Or rYear = Year) Then
                tbl.ListRows(iCt).Range.Copy
                targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
                jCt = jCt + 1
                Exit For  '<< stop checking this row
            End If

        Next c

    Next

    Range("Newrng").HorizontalAlignment = xlCenter
    Range("Newrng").VerticalAlignment = xlBottom
    Worksheets("Search").Columns("F:P").AutoFit

    Worksheets("Search").Month.Value = Null
    Worksheets("Search").Year.Value = Null
    Worksheets("Search").cbCerts.Value = Null


End Sub