VBA：復制並粘貼，然后搜索，復制並粘貼

Question

我需要你的幫助！ ：O當前，我有一個帶有宏的excel工作簿，該宏能夠進行搜索以找到具有該值的單元格並選擇整行。 之后，它將復制該行並將其粘貼到名為“搜索”的電子表格中。

但是，我需要更改宏以在執行搜索之前將固定數量的列標題行（例如第1至4行）復制並粘貼到電子表格（“搜索”），然后復制並粘貼到同一電子表格（“搜索”）中。

誰能告訴我該怎么做？ 我正在考慮這樣做（選擇，復制並粘貼然后搜索，選擇，復制並粘貼）或選擇多個范圍，例如（選擇第1至4行以及搜索后確定的行）。

    Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim LSearchValue As String

On Error GoTo Err_Execute

LSearchValue = InputBox("Please enter the staff ID.", "Enter value")

'Start search in row 5
LSearchRow = 6

'Start copying data to row 5 in Sheet1 (row counter variable)
LCopyToRow = 5

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

  'If value in column A = LSearchValue, copy entire row to Sheet1
  If Range("A" & CStr(LSearchRow)).Value = LSearchValue Then

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

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

  End If

  LSearchRow = LSearchRow + 1

Wend

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



Exit Sub

 Err_Execute:
  MsgBox "An error occurred."

End Sub

Answer 1

這是我的第一個答案，它只是整理您現有的代碼。 我所有的更改和添加都用“ quote hash”標記。 研究我所做的更改，並嘗試了解為什么要進行更改。 我計划另外兩個答案。

Option Explicit         '# Always include this statement at top
Sub SearchForString()

  Dim LSearchRow As Long        '# Integer creates 16-bit value which requires
  Dim LCopyToRow As Long        '# special processing on post-16-bit computers
  Dim LSearchValue As String

  Dim WshtSrc As Worksheet      '# Faster and more convenient if you are
  Dim WshtDest As Worksheet     '# working with more than one worksheet

  Set WshtSrc = Worksheets("Search")  '# These are probably the wrong
  Set WshtDest = Worksheets("Dest")   '# worksheet names

  '# I never use "On Error GoTo label" while developing macros because I want to
  '# know where an error occurs. Before release, I check for every condition that
  '# might lead to an error if possible.  If I cannot stop the possibility of an
  '# error, I will use "On Error Goto Next" and "On Error GoTo 0" either side of
  '# a problem statement and I will then test Err.  This will allows me to issue a
  '# useful message to the user even if I cannot do better.
  '# On Error GoTo Err_Execute

  LSearchValue = InputBox("Please enter the staff ID.", "Enter value")

  'Start search in row 5
  LSearchRow = 6

  'Start copying data to row 5 in Sheet1 (row counter variable)
  LCopyToRow = 5

  With WshtSrc

    While Len(.Range("A" & CStr(LSearchRow)).Value) > 0                 '#

      'If value in column A = LSearchValue, copy entire row to Sheet1
      If .Range("A" & CStr(LSearchRow)).Value = LSearchValue Then       '#

      .Rows(LSearchRow).Copy Destination:=WshtDest.Cells(LCopyToRow, 1)

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

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

      End If

      LSearchRow = LSearchRow + 1

    Wend

    'Position on cell A3
    'Range("A3").Select

  End With

  Exit Sub

'# Err_Execute:
'#    MsgBox "An error occurred."

End Sub

答案2

在LSearchValue = InputBox("Please enter the staff ID.", "Enter value")添加：

  If LSearchValue = "" Or LSearchValue = "Enter value" Then
    ' User does not want to make a selection
    Exit Sub
  End If

  WshtDest.Cells.EntireRow.Delete

  '# Copy heading rows
  WshtSrc.Rows("1:4").Copy Destination:=WshtDest.Range("A1")

我應該在第一個答案中包含前五行。 總是讓用戶說：“兄弟！我不是故意這樣做的”，並擺脫他們所做的選擇。 在開始新選擇之前，我應該已經清除了先前選擇的目標表。

最后的陳述是我知道復制四行的最簡單方法。

我在第一個答案中發現一個錯誤。 我錯過了兩個必要的更改：

    While Len(.Range("A" & CStr(LSearchRow)).Value) > 0

      If .Range("A" & CStr(LSearchRow)).Value = LSearchValue Then

我省略了Range前面的句點。 Range在活動工作表上運行。 .Range在With語句中指定的工作表上運行。

答案3

我在這個問題上不好，所以我是把水壺叫黑的鍋。 使用Excel的力量。 如果Excel具有執行所需功能的功能，請使用它。

對於我的測試數據，我有四列，我的員工ID是字母A到D。要獲取下面的宏，我：

• 打開宏錄制器
• 選擇了前四列
• 選擇自動過濾器將其打開
• 單擊列A頂部的箭頭，然后單擊值B
• 選擇自動過濾將其關閉
• 關閉宏錄制器

。

Sub Macro2()
'
' Macro2 Macro
' Macro recorded 21/05/2014 by Tony Dallimore
'

'
    Columns("A:D").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="B"
    Selection.AutoFilter
End Sub

在第二個AutoFilter語句之后，如果用戶選擇職員ID B，則該屏幕幾乎就是您要復制的內容。“幾乎完全”是因為第2至4行不可見。 如果可以告訴自動篩選器您有四個標題行，那么我不知道，所以我將以另一種方式解決該問題。

宏記錄器不知道您的目標。 該代碼在語法上是正確的，但它不是很好的代碼，因此必須進行整理。 另外，它不會復制行，因為我已經知道該怎么做。 下面的宏較小，如果您有很多行，則速度要快得多。

Sub SearchForString2()

  Dim LSearchValue As String

  Dim RngCopy As Range
  Dim RngData As Range

  Dim WshtSrc As Worksheet
  Dim WshtDest As Worksheet

  ' I should have included this in answer 1.  It stops the screen being repainted
  ' as the worksheets are changed which is both slow and irritating because of
  ' the flashing.
  Application.ScreenUpdating = False

  Set WshtSrc = Worksheets("Search")  '# These are probably the wrong
  Set WshtDest = Worksheets("Dest")   '# worksheet names

  LSearchValue = InputBox("Please enter the staff ID.", "Enter value")

  WshtDest.Cells.EntireRow.ClearContents

  If LSearchValue = "" Or LSearchValue = "Enter value" Then
    ' User does not want to make a selection
    Exit Sub
  End If

  With WshtSrc

    Set RngData = .Columns("A:D")   '   Change column range as necessary

    RngData.AutoFilter    ' Switch AutoFilter on.
    RngData.AutoFilter Field:=1, Criteria1:=LSearchValue
    .Rows("2:4").Hidden = False

    Set RngCopy = .Cells.SpecialCells(xlCellTypeVisible)

    RngCopy.Copy Destination:=WshtDest.Range("A1")

    RngData.AutoFilter ' Switch AutoFilter off.

  End With


  ' Note that there is no period before RngData or RngCopy.
  ' When you set a range, the worksheet is part of the range.
  ' So Columns is a "child" of WshtSrc but RngData and RngCopy are not.
  ' The following statement shows that RngData "knows" what worksheet
  'it applies to.

  Debug.Print "RngData's worksheet: " & RngData.Worksheet.Name

  Exit Sub

End Sub

Answer 2

您可以在搜索代碼時使用以下代碼：

Selection.Find(What:=LSearchValue, After:=ActiveCell, LookIn:=xlValues, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    True, SearchFormat:=False).Activate
Dim valuerow As Integer
valuerow = Application.ActiveCell.Row  

valuerow是找到的單元格的行索引