vba Excel 宏将数据从一个工作表复制并粘贴到另一个工作表

Excel macro to copy and paste data from one worksheet to another worksheet

提问by Raj

I am trying to Search for a value in a column and copy row from Sheet1 and creating new sheet as MySheet and pasting that particular row .But I am getting run time error while pasting data in MySheet.Any suggestions please.

我正在尝试搜索列中的值并从 Sheet1 复制行并将新工作表创建为 MySheet 并粘贴该特定行。但是在 MySheet 中粘贴数据时出现运行时错误。请提供任何建议。

Data Input I am trying :

我正在尝试的数据输入：

ID name price units desc

ID 名称 价格单位 desc

1 ikura 10 4 Mail Box

1 ikura 10 4 邮箱

2 test 11 14 xxxx

2 测试 11 14 xxxx

3 test 11 14 yyyy

3 测试 11 14 年

4 test 11 14 Mail Box

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

Regards,

问候，

Raju

拉朱

回答by Banjoe

First things first:

第一件事：

• Stop using .Select and .Activate when they're not needed, they're the devil's methods. Deal with range/worksheet objects directly.
• Change your row counters from intergers to longs just in case.
• Explicitly declaring which worksheet you're working with can save yourself from odd bugs/errors. If you don't like the typing use a worksheet object.
• Your error handler should always output err.Number and err.Description. If you'd done that from the beginning you probably wouldn't have had to post this question.
• Range.Copy has a destination argument. Use it instead of Range.Paste to save some potential headaches.

• 在不需要时停止使用 .Select 和 .Activate，它们是魔鬼的方法。直接处理范围/工作表对象。
• 以防万一，将行计数器从整数更改为长整数。
• 明确声明您正在使用哪个工作表可以避免奇怪的错误/错误。如果您不喜欢打字，请使用工作表对象。
• 您的错误处理程序应始终输出 err.Number 和 err.Description。如果你从一开始就这样做，你可能就不必发布这个问题了。
• Range.Copy 有一个目标参数。使用它而不是 Range.Paste 来避免一些潜在的麻烦。

Here's some simplified code, see if it works:

这是一些简化的代码，看看它是否有效：

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

回答by Reafidy

Try this simplified version:

试试这个简化版：

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