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

如果语句返回太多值

1 个答案: