复制符合条件的可见行并乘以百分比，然后粘贴到另一张工作表的最后一行

Question

只有删除条件，我才能成功执行上述主题。但一旦我把它放回去，它就不会执行或什么都不做。下面是我的带有标准的代码。我想知道如何包含这些标准并保持此代码正常运行。我需要 A 列中与 DB2 工作表中的单元格 B2 匹配的所有行，然后复制到 DB3 工作表的最后一行。感谢任何帮助。

Sub VisibleRowsAndMultiplyByPercentage()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRowSource As Long, lastRowDest As Long
    Dim criteria As Variant
    Dim i As Long, j As Long
    
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Sheets("DB2")
    Set wsDestination = ThisWorkbook.Sheets("DB3")
        
    ' Get the criteria value from cell B2 in destination sheet (Sheet5)
    criteria = wsSource.Range("B2").Value
      
    ' Find the last row in source sheet
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Find the last row in destination sheet column A
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1

    
    ' Loop through each row in column A of the source sheet
    For i = 3 To lastRowSource
        ' Check if the row is visible and column A matches the criteria (B2 value)
        If Not wsSource.Rows(i).Hidden And wsSource.Cells(i, 1).Value = criteria Then
            ' Copy values from column 1 to 10
            For j = 1 To 10
                wsDestination.Cells(lastRowDest, 1).Resize(, 10).Value = wsSource.Cells(i, 1).Resize(, 10).Value
            Next j
            ' Loop through columns 11 to 22 in the source row, multiply by percentage, and copy to destination sheet
            For j = 11 To 22
                ' Multiply the value by the corresponding percentage from row 1
                Dim multipliedValue As Double
                multipliedValue = wsSource.Cells(i, j).Value * wsSource.Cells(1, j).Value
                ' Copy the multiplied value to destination sheet
                wsDestination.Cells(lastRowDest, j).Value = multipliedValue
            Next j
            ' Move to the next row in destination sheet
            lastRowDest = lastRowDest + 1
        End If
    Next i
End Sub

Answer 1

这是您的代码，根据我在评论中提到的内容进行了调整：

Sub VisibleRowsAndMultiplyByPercentage()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRowSource As Long, lastRowDest As Long
    Dim criteria As Variant
    Dim i As Long, j As Long
    
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Sheets("DB2")
    Set wsDestination = ThisWorkbook.Sheets("DB3")
        
    ' Get the criteria value from cell B2 in destination sheet (Sheet5)
    criteria = wsSource.Range("B2").Value
      
    ' Find the last row in source sheet
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Find the last row in destination sheet column A
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1

    Dim arrPrint
    Dim multipliedValue As Double
    ReDim arrPrint(1 To 12)
    ' Loop through each row in column A of the source sheet
    For i = 3 To lastRowSource
        ' Check if the row is visible and column A matches the criteria (B2 value)
        If Not wsSource.Rows(i).Hidden And wsSource.Cells(i, 1).Value = criteria Then
            ' Copy values from column 1 to 10
            wsDestination.Cells(lastRowDest, 1).Resize(, 10).Value = wsSource.Cells(i, 1).Resize(, 10).Value
            ' Loop through columns 11 to 22 in the source row, multiply by percentage, and copy to destination sheet
            For j = 11 To 22
                ' Multiply the value by the corresponding percentage from row 1
                arrPrint(j - 10) = wsSource.Cells(i, j).Value * wsSource.Cells(1, j).Value
            Next j
            ' Copy the multiplied value to destination sheet
            wsDestination.Cells(lastRowDest, 11).Resize(, UBound(arrPrint)).Value = arrPrint
            ' Move to the next row in destination sheet
            lastRowDest = lastRowDest + 1
        End If
    Next i
End Sub

使用

Option Explicit

防止未声明的变量（和其他此类问题）导致问题；请参阅this如何在您将来的所有代码中自动设置它。