Vba 编辑代码以阻止用户从一张图纸跳到另一张图纸

我有一些代码，可以将数据从一张图纸复制到另一张图纸上，然后删除空行。代码可以正常工作，但我在执行时会将用户从一张工作表发送到另一张工作表。我还是VBA新手，现在我知道如何在不使用select属性的情况下实现结果。我需要编写代码来完成的是将数据从一个工作表移动到另一个工作表，并在单击按钮时删除空行。我希望用户在代码执行时留在头版。我的代码如下：

Sub MarkSold()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute

   'Start search in row 6
   LSearchRow = 6

   'Start copying data to row 6 in Sheet3 (row counter variable)
   LCopyToRow = 6

   While Len(Sheets("on stock").Range("B" & CStr(LSearchRow)).Value) > 0

      'If value in column B = "D5", copy entire row to Sheet3
      If Sheets("On stock").Range("B" & CStr(LSearchRow)).Value = Sheets("Data Entry").Range("D5") Then

         'Select row in Sheet1 to copy
         Sheets("On stock").Select
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Cut

         'Paste row into Sheet2 in next row
         Sheets("Turbines sold").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet1 to continue searching
         Sheets("On stock").Select

      End If

      LSearchRow = LSearchRow + 1

   Wend

Dim sh As Worksheet
Dim lr As Long, i As Long
    Set sh = Sheets("On stock")
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
        .EnableEvents = False

            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
            For i = lr To 6 Step -1
                If WorksheetFunction.CountA(Rows(i)) = 0 Then
                    Rows(i).EntireRow.Delete
                End If
            Next i

        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
        .ScreenUpdating = True
    End With

Call setupDV

   'Position on cell A3
   Application.CutCopyMode = False
   Sheets("Data Entry").Range("A1").Select

   MsgBox "Now marked as sold!"

   Exit Sub

Err_Execute:
   'MsgBox "An error occurred."

End Sub

---

感谢您的帮助

我已经对您的代码进行了一些清理并对其进行了评论，因此您可以按照更改的原因进行操作：

Sub MarkSold()
Dim sh As Worksheet
Dim lr As Long
Dim i As Long
Dim LSearchRow As Long
Dim LCopyToRow As Long
'the variables above ought to be declared as Long instead of Integer, as there
'are more cells in Excel than there are Integer values
On Error GoTo Err_Execute

   'Start search in row 6
LSearchRow = 6
   'Start copying data to row 6 in Sheet3 (row counter variable)
LCopyToRow = 6

    While Len(Sheets("On stock").Range("B" & LSearchRow).Value) > 0
      'If value in column B = "D5", copy entire row to Sheet3
      If Sheets("On stock").Range("B" & LSearchRow).Value = Sheets("Data Entry").Range("D5") Then
         'Select row in Sheet1 to copy
         Sheets("On stock").Rows(LSearchRow).Cut
         'Paste row into Sheet2 in next row
         Sheets("Turbines sold").Rows(LCopyToRow).Paste
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         'Go back to Sheet1 to continue searching
      End If
      LSearchRow = LSearchRow + 1
    Wend

    Set sh = Sheets("On stock")
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
        .EnableEvents = False

            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
            For i = lr To 6 Step -1
                If WorksheetFunction.CountA(Rows(i)) = 0 Then
                    Rows(i).EntireRow.Delete
                End If
            Next i

        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
        .ScreenUpdating = True
    End With

Call setupDV

   'Position on cell A3
   Application.CutCopyMode = False
   Sheets("Data Entry").Range("A1").Select
   'Do you really need the select command above?
   MsgBox "Now marked as sold!"
   Exit Sub
Err_Execute:
   'MsgBox "An error occurred."
End Sub

---

只需删除

。从代码中选择
语句，并设置直接将代码引用到每张工作表。就像下面的代码一样：

Sub MarkSold()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

Set stock = Sheets("On stock")
Set tSold = Sheets("Turbines sold")
Set dEntry = Sheets("Data Entry")
On Error GoTo Err_Execute

'Start search in row 6
LSearchRow = 6

'Start copying data to row 6 in Sheet3 (row counter variable)
LCopyToRow = 6

While Len(Sheets("on stock").Range("B" & CStr(LSearchRow)).Value) > 0

  'If value in column B = "D5", copy entire row to Sheet3
  If Sheets("On stock").Range("B" & CStr(LSearchRow)).Value = Sheets("Data Entry").Range("D5") Then

     'Select row in Sheet1 to copy
     Sheets("On stock").Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Cut

     'Paste row into Sheet2 in next row
     Sheets("Turbines sold").Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Paste

     'Move counter to next row
     LCopyToRow = LCopyToRow + 1

  End If

  LSearchRow = LSearchRow + 1

Wend

Dim sh As Worksheet
Dim lr As Long, i As Long
Set sh = Sheets("On stock")
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
    .EnableEvents = False

        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
        For i = lr To 6 Step -1
            If WorksheetFunction.CountA(Rows(i)) = 0 Then
                Rows(i).EntireRow.Delete
            End If
        Next i

    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayStatusBar = True
    .ScreenUpdating = True
End With

Call setupDV

Application.CutCopyMode = False

MsgBox "Now marked as sold!"

Exit Sub

Err_Execute:
'MsgBox "An error occurred."

End Sub

我建议您查看一下
应用程序。屏幕更新
和