Excel宏將數據從一個工作表複製和粘貼到另一個工作表

Question

我想在列中搜索一個值並從Sheet1複製一行並創建一個新的表格作爲MySheet並粘貼該特定的行。但是我得到運行時間在MySheet中粘貼數據時出錯。請提供任何建議。

數據輸入我試圖：

ID名稱價格單位降序

1伊倉10 4信箱

2試驗11 14 XXXX

3試驗11 14 YYYY

4測試11 14郵箱

Sub SearchForString() 

     Dim LSearchRow As Integer 
     Dim LCopyToRow As Integer 

     On Error GoTo Err_Execute 

     'Start search in row 4 
     LSearchRow = 4 

     'Start copying data to row 2 in Sheet2 (row counter variable) 
     LCopyToRow = 2 

    Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "MySheet" 
     While Len(Range("A" & CStr(LSearchRow)).Value) > 0 

      'If value in column E = "Mail Box", copy entire row to Sheet2 
      If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then 

       'Select row in Sheet1 to copy 
       Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
       Selection.Copy 

       'Paste row into Sheet2 in next row 
       Sheets("MySheet").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("Sheet1").Select 

      End If 

      LSearchRow = LSearchRow + 1 

     Wend 

     'Position on cell A3 
     Application.CutCopyMode = False 
     Range("A3").Select 

     MsgBox "All matching data has been copied." 

     Exit Sub 

    Err_Execute: 
     MsgBox "An error occurred." 

    End Sub 

個

問候，

拉朱

Answer 1

試試這個簡化版本：

Sub CopyData() 

    '// Turn off screen updating for cosmetics 
    Application.ScreenUpdating = False 

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MySheet" 

    '// Change this to your sheet you are copying from 
    With Sheet1 
     '// Filter all rows with Mail Box 
     .Range("E:E").AutoFilter Field:=1, Criteria1:="Mail Box", Operator:=xlAnd 
     '// Copy all rows except header 
     .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Worksheets("MySheet").Cells(2, 1) 
     '// Remove the autofilter 
     If .AutoFilterMode Then .AutoFilterMode = False 
    End With 

    Application.ScreenUpdating = True 

    MsgBox "All matching data has been copied." 

End Sub 

Answer 2

首先第一件事情：使用。選擇和.Activate

• 停止不是在需要的時候，他們是 魔鬼的方法。直接處理範圍/工作表對象。
• 將行計數器從整數變爲長整數以防萬一。
• 明確聲明您正在使用哪個工作表可以讓您避免出現奇怪的錯誤/錯誤。如果你不喜歡打字，請使用工作表對象。
• 您的錯誤處理程序應始終輸出err.Number和 err.Description。如果你從一開始就做到了這一點，你可能不需要發表這個問題 。
• Range.Copy有一個目標參數。用它代替Range.Paste 可以節省一些潛在的麻煩。

下面是一些簡單的代碼，看看它是否工作：

Sub SearchForString() 
Dim LSearchRow As Long 
Dim LCopyToRow As Long 
Dim wksInput As Worksheet 
Dim wksOutput As Worksheet 

On Error GoTo Err_Execute 

'Create a new sheet output to and store a reference to it 
'in the wksOutput variable 
Set wksOutput = Worksheets.Add(AFter:=Worksheets(Worksheets.Count)) 
wksOutput.Name = "MySheet" 

'The wksInput variable will hold a reference to the worksheet 
'that needs to be searched 
Set wksInput = ThisWorkbook.Worksheets("Sheet2") 

'Start copying data to row 2 in Sheet2 (row counter variable) 
LCopyToRow = 2 
'Loop through all the rows that contain data in the worksheet 
'Start search in row 4 
For LSearchRow = 4 To wksInput.UsedRange.Rows.Count 
    'If value in column E = "Mail Box", copy entire row to wksOutput 
    If wksInput.Cells(LSearchRow, 5) = "Mail Box" Then 
     'One line copy/paste 
     wksInput.Rows(LSearchRow).Copy wksOutput.Cells(LCopyToRow, 1) 
     'Increment the output row 
     LCopyToRow = LCopyToRow + 1 
    End If 
Next LSearchRow 

With wksInput 
    .Activate 
    .Range("A3").Select 
End With 



    MsgBox "All matching data has been copied." 

Exit Sub 
Err_Execute: 
    MsgBox "An error occurred. Number: " & Err.Number & " Description: " & Err.Description 
End Sub