Question

我有一个宏，我在这里与其他用户一起提供了巨大的帮助。然后我稍微编辑它以满足我的需要。

现在，运行宏将使Excel在Sheet2的第V列中查找大于0的任何数值。如果存在大于0的值，则复制同一行的单元格S：V。然后，Excel将在列T中查找包含数据的最后一行，然后移到下一行。然后，Excel会将单元格S：V中的数据粘贴到此行中。之后，它将返回到Sheet2并继续在第V列中查找存在的下一个值并重新执行它直到它到达列的末尾。

我的问题是，当您运行宏两次时，它将根据需要执行两次操作，从而导致重复值。我希望Excel执行一次宏，然后如果它再次运行，没有任何事情发生。我试图防止人为错误，以防有人意外地运行宏两次并且没有注意到它。这可能吗？

    Sub CopyPaste()

    Dim c As Range
    Dim IRow As Long, lastrow As Long
    Dim rSource As Range
    Dim wsI As Worksheet, wsO As Worksheet
    Dim endrow As Long


    On Error GoTo Whoa


    '~~> Sheet Where values needs to be checked
    Set wsI = ThisWorkbook.Sheets("Sheet2")
    '~~> Output sheet
    Set wsO = ThisWorkbook.Sheets("Sheet1")

    Application.ScreenUpdating = False

    'Look for last row with data in column T and move to next
    endrow = wsO.Cells(Rows.Count, "T").End(xlUp).Row + 1


    With wsI
        '~~> Find Last Row which has data in Col S to V
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then

            lastrow = .Columns("S:V").Find(What:="*", _
                          After:=.Range("S1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lastrow = 1
        End If


        Set rSource = .Range("V1:V" & lastrow)


            If IsNumeric(c.Value) Then
                If c.Value > 0 Then
                    wsO.Cells(endrow + IRow, 20).Resize(1, 4).Value = _
                         .Range("S" & c.Row & ":V" & c.Row).Value
                    wsO.Cells(endrow + IRow, 25).Value = "ID#" & .Range("J" & c.Row).Value
                    IRow = IRow + 1
                End If
            End If

        Next
    End With

 LetsContinue:
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    Exit Sub
 Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Answer 1

防止人为错误的另一种解决方案（更像是创可贴解决方案）：

If MsgBox("Are you sure you want to run this macro? Running it a second time can result in duplicate values! Proceed?", vbYesNo + vbQuestion) = vbNo Then Exit Sub

将它放在宏的开头可以警告用户不要意外地运行它。

Answer 2

正如SJR提到为什么在再次运行代码之前不清除wsO：

Sub CopyPaste()

Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet
Dim endrow As Long


On Error GoTo Whoa


'~~> Sheet Where values needs to be checked
Set wsI = ThisWorkbook.Sheets("Sheet2")
'~~> Output sheet
Set wsO = ThisWorkbook.Sheets("Sheet1")

wsO.Rows("2:" & Rows.Count).ClearContents
'the above line will clear the sheet from Row 2 to the last (in case you have headers, if not then change 2 to 1

Application.ScreenUpdating = False

'Look for last row with data in column T and move to next
endrow = wsO.Cells(Rows.Count, "T").End(xlUp).Row + 1


With wsI
    '~~> Find Last Row which has data in Col S to V
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then

        lastrow = .Columns("S:V").Find(What:="*", _
                      After:=.Range("S1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastrow = 1
    End If


    Set rSource = .Range("V1:V" & lastrow)


        If IsNumeric(c.Value) Then
            If c.Value > 0 Then
                wsO.Cells(endrow + IRow, 20).Resize(1, 4).Value = _
                     .Range("S" & c.Row & ":V" & c.Row).Value
                wsO.Cells(endrow + IRow, 25).Value = "ID#" & .Range("J" & c.Row).Value
                IRow = IRow + 1
            End If
        End If


End With

LetsContinue:
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

多次运行时如何阻止宏重复？

2 个答案: