Search for a text in a column when found copy cell above it

[Closed]
Report
Posts
2
Registration date
Friday January 4, 2013
Status
Member
Last seen
January 5, 2013
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,

Boy Results
Ttstm063
Mark Earned
Points Earned
Boy Results
Ttstm063
Mark Earned
Points Earned
Boy Results
Boy Results
Ttstm063
Mark Earned
Points Earned
Girl Results
Ttstm063

Here is sample of my data in column A, out of 60000 cells. what I want to archive is a code to search by Ttstm063 if found copy Cell above and paste Results to column C loop until end of data in column A

I am trying to use this code , am very green at these codes as I get no results

Sub Macro3()
ActiveCell.Offset(0, 0).Range("A1").Select
Cells.Find(What:="Ttst063", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-2, 0).Range("A1").Select
Selection.Copy
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(2, -2).Range("A1").Select
Cells.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(-2, 0).Range("A1").Select
Selection.Copy
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

Thank you for your help 1000000 times
ReC

2 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
try this

Sub Macro3()
    Dim maxRows         As Long
    Dim processRow      As Long
    Dim targetRow       As Long
    Dim sheetName       As String
    Dim searchItem      As String
    
    sheetName = ActiveSheet.Name
    
    With Sheets(sheetName)
    
        searchItem = "Ttstm063"
        
        'find max rows in the target sheet
        maxRows = getItemLocation("*", .Cells)
        lProcessRow = 1
        
        'find where the item is located with in range specified
        targetRow = getItemLocation(searchItem, .Range(.Cells(lProcessRow, "A"), .Cells(maxRows, "A")), bLastOccurance:=False)
        
        'LOOP WHILE WE ARE FINDING THE ITEM
        Do While (targetRow > 0)
            If (targetRow > 0) Then
                
                Application.CutCopyMode = False
                .Cells(targetRow - 2, "A").Copy
                .Cells(targetRow - 2, "c").PasteSpecial
                Application.CutCopyMode = False
                
                'MOVE ONE ROW AFTER CURRENT FIND
                lProcessRow = targetRow + 1
                
                'EXHAUSTED ROWS
                If lProcessRow > maxRows Then Exit Sub
                
                'FIND NEXT MATCH
                targetRow = getItemLocation(searchItem, .Range(.Cells(lProcessRow, "A"), .Cells(maxRows, "A")), bLastOccurance:=False)
            End If
        Loop
    End With
End Sub
Posts
2
Registration date
Friday January 4, 2013
Status
Member
Last seen
January 5, 2013

Hi rizvisa1
Thank you for your response, however ,

at this line maxRows = getItemLocation("*", .Cells)
I get error compile error: Sub or Function not defined therefore I cannot test it.

Recy
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Oh I thought I had edited thread to add that . This is the full code

Sub Macro3()
    Dim maxRows         As Long
    Dim processRow      As Long
    Dim targetRow       As Long
    Dim sheetName       As String
    Dim searchItem      As String
    
    sheetName = ActiveSheet.Name
    
    With Sheets(sheetName)
    
        searchItem = "Ttstm063"
        
        'find max rows in the target sheet
        maxRows = getItemLocation("*", .Cells)
        lProcessRow = 1
        
        'find where the item is located with in range specified
        targetRow = getItemLocation(searchItem, .Range(.Cells(lProcessRow, "A"), .Cells(maxRows, "A")), bLastOccurance:=False)
        
        'LOOP WHILE WE ARE FINDING THE ITEM
        Do While (targetRow > 0)
            If (targetRow > 0) Then
                
                Application.CutCopyMode = False
                .Cells(targetRow - 2, "A").Copy
                .Cells(targetRow - 2, "c").PasteSpecial
                Application.CutCopyMode = False
                
                'MOVE ONE ROW AFTER CURRENT FIND
                lProcessRow = targetRow + 1
                
                'EXHAUSTED ROWS
                If lProcessRow > maxRows Then Exit Sub
                
                'FIND NEXT MATCH
                targetRow = getItemLocation(searchItem, .Range(.Cells(lProcessRow, "A"), .Cells(maxRows, "A")), bLastOccurance:=False)
            End If
        Loop
    End With
End Sub

Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
                                   
   'find the first/last row/column  within a range for a specific string
      
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
         
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
         
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
         
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
some thing is wrong with this web site. it is deleting the msg.
You can find that missing function from this
https://ccm.net/forum/affich-606042-excel-vba2010-select-cells-between-2-keywords