Copy_search_copy_paste_macro Closed

Question

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



Configuration: Windows XP / Internet Explorer 8.0

rizvisa1 · Answer

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

Copy_search_copy_paste_macro

1 response

Subscribe To Our Newsletter!