find text and selecting current region than copy paste to different sheet till all is copied

[zohaib]

Hello,

I have attached the file I am referencing. I want to copy all "123 + current region" and paste it into different sheet. please see sheet "results" for example. I wanted to do this in VBA code. thanks in advance for your help.

thank you,
Zohaib

 

[Luke M]

Try this.

Sub Transfer123()
Dim fCell As Range
Dim firstAdd As String
Dim pasteRow As Long
Dim pasteCol As String
Dim wsDest As Worksheet
Dim wsSource As Worksheet


'Which column to go to?
pasteCol = "A"
'Where are we going to?
Set wsDest = Worksheets("Results")
'Where are we coming from?
Set wsSource = Worksheets("Sheet1")

Application.ScreenUpdating = False
'Search for the 123 value
With wsSource.Range("A:A")
    Set fCell = .Find(what:=123, lookat:=xlWhole, LookIn:=xlValues)
   
    If fCell Is Nothing Then
        MsgBox "No values found"
        Exit Sub
    End If
    firstAdd = fCell.Address
    Do
        pasteRow = wsDest.Cells(.Rows.Count, pasteCol).End(xlUp).Offset(1).Row
        If pasteRow > 2 Then pasteRow = pasteRow + 1
        fCell.CurrentRegion.Copy wsDest.Cells(pasteRow, pasteCol)
        Set fCell = .FindNext(fCell)
    Loop Until fCell.Address = firstAdd
End With

Application.ScreenUpdating = True
End Sub

 

[Marc L]

Hi !

Same as Luke with a direct Copy :​

Sub Demo()
    Dim Rg As Range
With Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp))
    Set Rg = .Find(123, .Cells(.Count), xlValues, xlWhole)
     If Rg Is Nothing Then Beep: Exit Sub
    Application.ScreenUpdating = False
                           AD$ = Rg.Address
        Sheet2.UsedRange.Clear
    Do
               Rg.CurrentRegion.Copy Sheet2.Cells(Rows.Count, 1).End(xlUp)(3 + (Rg.Address = AD))
           Set Rg = .FindNext(Rg)
    Loop Until Rg.Address = AD
           Set Rg = Nothing
End With
Application.Goto Sheet2.Cells(1), True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Luke M]

Lol, had to go and 1-up me, @Marc L?

 

[zohaib]

Hello Luke,

Your formula works on my example but when i replace it with " ---------- ------------ ---------- -------------- " it is doesnt work? for example purpose i put "123" but when i change the formula to below. it doesnt work. Any help is appreciated. thanks

Sub Transfer123()
Dim fCell As Range
Dim firstAdd As String
Dim pasteRow As Long
Dim pasteCol As String
Dim wsDest As Worksheet
Dim wsSource As Worksheet


'Which column to go to?
pasteCol = "A"
'Where are we going to?
Set wsDest = Worksheets("Results")
'Where are we coming from?
Set wsSource = Worksheets("Sheet1")

Application.ScreenUpdating = False
'Search for the 123 value
With wsSource.Range("A:A")
    Set fCell = .Find(what:=              ----------    ------------    ----------    --------------    , lookat:=xlWhole, LookIn:=xlValues)
 
    If fCell Is Nothing Then
        MsgBox "No values found"
        Exit Sub
    End If
    firstAdd = fCell.Address
    Do
        pasteRow = wsDest.Cells(.Rows.Count, pasteCol).End(xlUp).Offset(1).Row
        If pasteRow > 2 Then pasteRow = pasteRow + 1
        fCell.CurrentRegion.Copy wsDest.Cells(pasteRow, pasteCol)
        Set fCell = .FindNext(fCell)
    Loop Until fCell.Address = firstAdd
End With

Application.ScreenUpdating = True
End Sub

 

[Marc L]

As the search in not a number anymore, you just forgot double quotes …
​

 

[Luke M]

Sorry for the confusion. Marc is correct, if you're looking for a string now, line should be

Set fCell = .Find(what:= "---------- ------------ ---------- --------------" , lookat:=xlWhole, LookIn:=xlValues)

Or, since it's more likely that you don't have long series of dashes all over the place, could change the find to just look at part of the cell, and do:

Set fCell = .Find(what:= "---" , lookat:=xlPart, LookIn:=xlValues)

 

[zohaib]

THANK YOU GUYS!!!!!! It works PREFECT thanks

Zohaib