Copy_search_copy_paste_macro

Closed
Dave - Feb 9, 2011 at 05:26 PM
 Dave - Feb 10, 2011 at 02:03 AM
Hello,

I am trying to create a macro.

I am using a workbook with three separate pages

I need the macro to copy the contents of a single cell - containing a UPC Code -from page 1 it will be in a contineous collum of UPC data



749186214459 => start here (perform routine)

749186057452 <= do this one next and continue to completion

749186202098

749186105252

43538634262

43538743490

43538610754

43538322060

43538049851

43538892211

43538394289

=> End Sub



(This is the required routine once the target cell has the macro executed)

Copy contents -

Switch to another page of the worksheet (page 2)

Search a collum of that sheet and locate the matching target which is the same

UPC copied from (page 1)

Once the target UPC is found

Select the entire row of data that contains that target UPC

switch pages to a third sheet

and paste the row into the next available row

This much would be great.



If it could then return to page 1

select the next UPC code in the collum and repeat the process

until it reaches the end of the collum - that would be perfect.

I have tried repeatedly to create this macro and am getting

frustrated. The code embeds the contents of the last cell

searched and over-writes this information on the next UPC

code in the collum.



Code:



Sub Macro30()

'

' Macro30 Macro

'

' Keyboard Shortcut: Ctrl+q

'

ActiveCell.Select

Selection.Copy

ActiveCell.Offset(-14, 0).Range("A1").Select

Sheets("InventoryExport_1-28-2011-14-28").Select

ActiveWindow.ScrollColumn = 9

ActiveWindow.ScrollColumn = 8

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 3

ActiveWindow.ScrollColumn = 1

ActiveCell.Offset(0, -9).Columns("A:A").EntireColumn.Select

Selection.Find(What:="749186214459", After:=ActiveCell,

LookIn:= _

xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows,

SearchDirection:= _

xlNext, MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Rows("1:1").EntireRow.Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet2").Select

ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select

ActiveSheet.Paste

ActiveCell.Offset(1, 0).Range("A1").Select

Sheets("Sheet1").Select

End Sub



I know my first problem is this line:

Selection.Find(What:="749186214459", After:=ActiveCell,

LookIn:=



I need to replace the specific contents of the target cell (in this

case "749186214459") with a bolean value or indicate - to

pick-up whatever contents are found associated with the

target cell.

My second problem is this line:



Selection.Find(What:="749186214459", After:=ActiveCell,



Again - the target cell contents become part of the macro and

cause problems when i reuse the macro on the next cell. - It

overwrites the contents with the embedded contents.



Can a macro be programed to select the contents of a cell,

paste it, search for it on another sheet, copy the row it is in,

paste it in a third sheet and return to repeat the process with

the next record?



Please let me know - any guidance is appreciated.

Email id removed for security



1 response

rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Feb 9, 2011 at 10:58 PM
Try this


Sub doMatchAndCopy()

   Dim sSrcSheet           As String  'sheet where values to be searched are
   Dim sLookUpSheet        As String  'sheet where matching rows are to be found
   Dim sFinalSheet         As String  'sheet where the matched rows are to be pasted
   Dim sSrcValue           As String
   
   Dim lSrcRow             As Long
   Dim lLookUpRow          As Long
   Dim lFinalRow           As Long
   Dim rngFinalCell       As Range
   
   'three sheets
   sSrcSheet = "Sheet1"
   sLookUpSheet = "Sheet2"
   sFinalSheet = "Sheet3"
   
   'find the last used cells on the final sheet where matched rows would be pasted
   Set rngFinalCell = Sheets(sFinalSheet).Cells.Find("*", Sheets(sFinalSheet).Cells(1, 1), , , xlByRows, xlPrevious)
   If (rngFinalCell Is Nothing) _
   Then
      lFinalRow = 1
   Else
      lFinalRow = rngFinalCell.Row
   End If
   Set rngFinalCell = Nothing
   
   'going thru each row of source sheet till we encounter a blank cell
   lSrcRow = 2
   Do While (Sheets(sSrcSheet).Cells(lSrcRow, "A") <> vbNullString)
      
      sSrcValue = Sheets(sSrcSheet).Cells(lSrcRow, "A")
      
      On Error Resume Next
      lLookUpRow = 0
      lLookUpRow = Application.WorksheetFunction.Match(sSrcValue, Sheets(sLookUpSheet).Range("A:A"), 0)
      Err.Clear
      On Error GoTo 0
      If (lLookUpRow > 0) _
      Then
         Application.CutCopyMode = False
         lFinalRow = lFinalRow + 1
         Sheets(sLookUpSheet).Rows(lLookUpRow).Copy
         Sheets(sFinalSheet).Cells(lFinalRow, "A").PasteSpecial
         Application.CutCopyMode = False
      End If
      
      lSrcRow = lSrcRow + 1
   Loop
   
End Sub
0
Wow, thank you - I will try it.
0