VBA in Excel 查找所有包含特定文本的内容并复制并粘贴到新工作表

Question

我是 VBA 的新手，我正在尝试在我的报价工作表中重新创建“查找所有”功能，以复制并粘贴 B 列（B30 和 B350 之间）中包含 , CB（在中间）的任何行文本）复制并粘贴到新工作表（工单）中，以在 AA 列制定零件清单。

Sub CreateWorkOrder()
 Dim quote As Worksheet
 Dim Work_Order As Worksheet
 Dim CB As String
 Dim finalrow As Integer
 Dim i As Integer

Set quote = Sheet1
Set Work_Order = Sheet10
CB = quote.Range("B2").Value
number = "*, CB*"

'goto sheet and start searching and copying
quote.Select
finalrow = 350

'loop through the rows to find the matching records
For i = 30 To finalrow

If Cells(i, 2) = CB Then
    Range(Cells(i, 1), Cells(i, 2)).Copy
    Work_Order.Select
    Range("AA300").End(xlUp).Offset(1, 0).PasteSpecial xlpastevalue
    Range("AA" & i + 1).PasteSpecial xlPasteValues
    quote.Select
    End If
Next i
Work_Order.Select
Range("B21").Select
End Sub

我得到范围 class 的 PasteSpecial 方法在

处失败

Range("AA300").End(xlUp).Offset(1, 0).PasteSpecial xlpastevalue

Answer 1

一般不用.Select，最好avoid using .Select。

试试这个：

Sub CreateWorkOrder()
Dim quote As Worksheet
Dim Work_Order As Worksheet
Dim CB As String
Dim finalrow As Integer
Dim i As Integer

Set quote = Sheet1
Set Work_Order = Sheet10
CB = quote.Range("B2").Value
Number = "*, CB*"

finalrow = 350

'loop through the rows to find the matching records
For i = 30 To finalrow
    If quote.Cells(i, 2) = CB Then
        quote.Range(quote.Cells(i, 1), quote.Cells(i, 2)).Copy
        Work_Order.Range("AA300").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Work_Order.Range("AA" & i + 1).PasteSpecial xlPasteValues
    End If
Next i
'  Leaving in the below just so it goes to a sheet
'  and selects the cell for the user.
Work_Order.Activate
Work_Order.Range("B21").Select
End Sub

Answer 2

AutoFilter 方法避免循环：

Sub CreateWorkOrder()

    Dim quote As Worksheet
    Dim Work_Order As Worksheet
    Dim CB As String

    Set quote = Sheet1
    Set Work_Order = Sheet10
    CB = quote.Range("B2").Value
    If Len(CB) = 0 Then Exit Sub    'No criteria

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With quote.Range("B29", quote.Cells(quote.Rows.Count, "B").End(xlUp))
        If .Row = 29 And .Rows.Count > 1 Then
            .AutoFilter 1, "*" & CB & "*"
            Intersect(.Parent.Range("A:B"), .Offset(1).EntireRow).Copy
            Work_Order.Cells(Work_Order.Rows.Count, "AA").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            .AutoFilter
        End If
    End With

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

End Sub

VBA in Excel 查找所有包含特定文本的内容并复制并粘贴到新工作表

VBA in Excel to Find all containing specific text and copy and paste to new worksheet

excel

vba

copy-paste

find