Question

我有一些代码可以将数据从一个工作表复制到另一个工作表，然后删除空行。代码类型有效，但我在执行时将用户从工作表发送到工作表。我还是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

感谢任何帮助！

Answer 1

只需从您的代码中删除 .Select 语句并将您的代码直接引用到每个工作表。就像下面的代码：

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

Answer 2

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

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

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

2 个答案: