VBA：复制并粘贴，然后搜索，复制并粘贴

Question

I need your help please!! :O Currently I have an excel workbook with a macro that is able to do a search to locate the cell with the value and select the entire row. After which it will copy & paste the row to a spreadsheet called "Search".

However, I need to alter the macro to copy & paste a fixed number of column header rows eg row 1 to 4 to the spreadsheet ("Search") before performing the search, copy & paste into the same spreadsheet ("Search").

Can anyone advise me how to do it? I was thinking of either doing it like this (select, copy and paste THEN search, select, copy and paste) or selecting multiple range eg (select row 1 to 4 AND the row identified after the search).

    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

This is my first answer which simply tidies up your existing code. All my changes and additions are marked with "quote hash". Study the changes I have made and try to understand why I have made them. I plan two further answers.

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

Answer 2

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

  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")

I should have included the first five lines in the first answer. Always give the user the means of saying: "Bother! I did not mean to do that" and getting out of the selection they have made. I should have cleared the destination sheet of the previous selection before starting the new one.

The final statement is the easiest way I know of copying four rows.

I have noticed an error in my first answer. I missed two necessary changes:

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

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

I omitted the periods in front of Range. Range operates on the active worksheet. .Range operates on the worksheet specified in the With statement.

Answer 3

I am not good on this issue so I'm the pot calling the kettle black. Use the power of Excel. If Excel has a function that does what you want then use it.

For my test data, I have four columns and my staff Ids are the letters A to D. To get the macro below, I:

• switched the macro recorder on
• selected the first four columns
• selected AutoFilter to switch it on
• clicked the arrow at the top of column A and clicked value B
• selected AutoFilter to switch it off
• switched the macro recorder off

.

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

Following the second AutoFilter statement, the screen was almost exactly what you want to copy if the user selects staff Id B. The "almost exactly" is because rows 2 to 4 are invisible. If there is a way of telling AutoFilter you have four heading rows then I do not know it so I will fix that problem in a different way.

The Macro Recorder does not know your objectives. This code is syntactically correct but it is not good code so it will have to be tidied up. Also, it does not copy the rows because I already know how to do that. The macro below is smaller and if you have many rows, much faster.

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

You can use this code as you search code :

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 is the row index of the found cell