Question

因此，经过大约3个小时或更长时间搜索谷歌并获得答案后，我似乎无法找到适合我特定情况的答案。我一直在努力解决一个宏，最后让它主要工作但是让它复制/粘贴到一张新工作表让我感到烦恼。这是复制/粘贴行（也是我在放弃之前尝试制作的先前复制/粘贴）：

Sub Filtration()

Application.Goto Sheet1.Range("R1")
Application.ScreenUpdating = False

Dim writeRow As Integer
Dim percentage As Double

'to create skip conditions for row 1 & 2
counter = 1
For Each Cell In Sheets(1).Range("R:R")            
    'second part of skip condition
    If counter > 2 Then    
        'creates condition to ignore blank cells or cells with a zero or negative number
        If Cell.Value = "" Or Cell.Value <= 0 Then

        Else
            'creates a way to ignore offset cells if =< 0 (might need to add in for blank too)
            If Cell.Offset(, -2).Value <= 0 Then
                percentage = 0
            Else
                percentage = Cell.Value / Cell.Offset(, -2).Value                            
            End If    
            'divide the current cell's value by the the cell one column over's value and compare
            If percentage > 0.02 Then                
                Set Mastersheet = Worksheets("Sheet1")  ' Copy From this sheet
                Set Pastesheet = Worksheets("Sheet2")  ' to this sheet
                Cell.EntireRow.Copy  ' copy the row from column O that meets that requirements (above, 1 and also win in Q)
                'Pastesheet.Cells(lastRow + 1, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

                Dim LastRow As Long
                With Pastesheet
                    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in column "A
                    .Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
                End With                
            End If
        End If

    End If

    'final part of skip condition to ignore the two headers - has to be here to work, before next but after the last End IF
    counter = counter + 1        
Next
Application.ScreenUpdating = True

End Sub

评论的复制/粘贴只是在我writeRow部分出错，无法找出原因，搜索也没有理由。下半部分工作，但只是一遍又一遍地覆盖同一行，我在那里发现的所有答案和例子都声称它应该有效，所以我很茫然。有没有人有任何想法？

Answer 1

我想你的意思是下面的代码（这部分代码只关注粘贴部分）：

Dim LastRow As Long
Dim LastCell As Range

With Pastesheet
    ' safer way to get the last row
    Set LastCell = .Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, _
                        searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
    If Not LastCell Is Nothing Then
        LastRow = LastCell.Row
    End If

    .Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End With

Excel VBA复制/粘贴覆盖同一行

1 个答案: