VBA在Excel中查找包含特定文本的所有內容並將其復制並粘貼到新工作表中

Question

我是VBA的新手，正嘗試在報價工作表中重新創建“查找全部”功能，以將包含CB的B列（在B30和B350之間）中的任何行復制並粘貼到B列中（在文本中間），以將其復制並粘貼到一個新的工作表（工單）以在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

我得到范圍類的PasteSpecial方法失敗

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

Answer 1

通常不需要使用.Select ，最好避免使用.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