Finding the text and moving Next cell

[AT BABU]

Hi All,

Thank for your support for learning for VBA

I have a small problem, I find the text and copy 7 cell in the Active sheet but code not move Next finding. This my code


Cells.Find(What:="Date", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
Range(ActiveCell, ActiveCell.Offset(0, 9)).Copy

[TABLE="width: 70"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Date[/TD]
[/TR]
[TR]
[TD]View[/TD]
[/TR]
[TR]
[TD]work[/TD]
[/TR]
[TR]
[TD]Key Observations

Empty cells

[TABLE="width: 70"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Date[/TD]
[/TR]
[TR]
[TD]View[/TD]
[/TR]
[TR]
[TD]work[/TD]
[/TR]
[TR]
[TD]Key Observations[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]

 

[nardagus]

Hello,

To find every cell containing searched text you have to write a loop for that.
Dunno what do you want to do with copied data, so I skipped that piece of code.

Try this:

Sub atbabu()
Dim cfound As String
    With ActiveWorkbook.ActiveSheet
        With .Cells
            Set c = .Find(What:="Date", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
        End With
    If Not c Is Nothing Then
        cfound = c.Address
        .Range(c.Address, c.Offset(0, 9)).Copy
        'I think here you should paste the data somewhere
    End If
        
        Do While Not c Is Nothing
            With .Cells
                Set c = .FindNext(c)
            End With
            If cfound = c.Address Then
                Exit Do
            ElseIf Not c Is Nothing Then
                .Range(c.Address, c.Offset(0, 9)).Copy
                'I think here you should paste the data somewhere
            End If
        Loop
    
    End With
End Sub

Cheers

 

[DanteAmor]

I find the text and copy 7 cell ... Range(ActiveCell, ActiveCell.Offset(0, 9)).Copy

Do you need to copy 7 rows or 9 columns or a range of 7 rows and 9 columns?
If there are 7 rows then f.Resize(7).Copy
If there are 9 columns then f.Resize(1, 9).Copy
If there are 7 rows and 9 columns then f.Resize(7, 9).Copy

Sub test()
  Dim c As Range, f As Range, cell As String
  Set f = Cells.Find("Date", , xlValues, xlWhole)
  If Not f Is Nothing Then
    cell = f.Address
    Do
[COLOR=#0000ff]      f.Resize(7, 9).Copy[/COLOR]
[COLOR=#008000]      'Here goes the part to paste somewhere[/COLOR]
      Set f = Cells.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If
End Sub

 

[AT BABU]

Thank you so much it working

I have small problem with code after copy data and in pasting problem. after run code only one value present

Sheet1.Activate
Range("A1").Activate
  Dim c As Range, f As Range, cell As String
  Set f = Cells.Find("Date", , xlValues, xlWhole)
  If Not f Is Nothing Then
    cell = f.Address
    Do
    ActiveCell.Offset(1, 0).Activate
      f.Resize(1, 9).Copy
      Sheet9.Activate
    'I think here you should paste the data somewhere
    [B]Range("A1", Range("A" & Rows.Count).End(xlUp)).PasteSpecial[/B]
     Sheet1.Activate
      Set f = Cells.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If

 

[AT BABU]

loop runing with out breack

 

[DanteAmor]

It works now?

It is not necessary to change the sheet, try:

  Dim c As Range, f As Range, cell As String
  Set f = Cells.Find("Date", , xlValues, xlWhole)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      f.Resize(1, 9).Copy
      Sheet9.Range("A" & Sheet9.Range("A" & Rows.Count).End(xlUp).row +1).PasteSpecial xlpastevalues
      Set f = Cells.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If

 

[AT BABU]

Wow working fine

Thank you DanteAmor

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[AT BABU]

Hi DanteAmor,

I write code for Empty cells But not working. if I wrong please correct me

Sub Emptycells()
Range("B2").Select
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = 0 Then
ActiveCell.Offset(0, 1).Resize(1, 5).Copy

Else
ActiveCell.Offset(1, 0).Select
Loop
End Sub

 

[DanteAmor]

I will gladly help you, but if it is a new requirement you must create a new thread and explain in detail what you have on the sheet and what you expect from the result.