Solved: Copy & Paste to the next cell in the row?

[Carpiem]

Hello All,

Hoping someone can fix my macros that use ?Find? to locate all rows (In Column A) with the word ?Total? and then copy the active cell and paste it to the next cell in that row.

With the attached file this would translate as the ?Yellow? highlighted cells (G4, G7 and G12).

The following 2 macros in use don?t quite work. Row 12 cell ?F12? is copied to ?G12? and but nothing happens in rows 4 & 7.

[VBA]
Sub Totals()

FindThis

Cells(ActiveCell.Row, ActiveCell.Column + 5).Copy
With Selection
Cells(ActiveCell.Row, ActiveCell.Column).Offset(0, 6).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End With

[A2].Select

End Sub
Private Sub FindThis()
Dim Cell As Range, FirstAddress As String
With Range("Column")
Set Cell = .Find("Total", LookIn:=xlValues, searchorder:=xlByRows, _
LookAt:=xlPart, MatchCase:=True)

'Error handling if no "Total" found
On Error GoTo Finish
'Start Point of Search
FirstAddress = Cell.Address
Do

Cell.Select

Set Cell = .FindNext(Cell)

Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End With
Finish:
End Sub
[/VBA]

Any help is much appreciated? Thank you in advance.

Carpiem

[jungix]

You loop for every cell with the word "Total" first, and you only copy your cell at the end for the last cell found. You have to include your code inside the loop in order to do it each time

[makako]

[VBA]
Option Explicit
Sub McTotals()
Dim FirstAddress As String, Cell As Range

With Selection
Set Cell = Range("Column").Find("Total", LookIn:=xlValues, searchorder:=xlByRows, _
LookAt:=xlPart, MatchCase:=True)

'Error handling if no "Total" found
On Error GoTo Finish
'Start Point of Search
FirstAddress = Cell.Address
Do
Cell.Select
Set Cell = Range("Column").FindNext(Cell)
Cells(ActiveCell.Row, ActiveCell.Column + 5).Copy
Cells(ActiveCell.Row, ActiveCell.Column).Offset(0, 6).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End With
Finish:
End Sub
[/VBA]
maybe this helps?

[mdmackillop]

[VBA]Sub Tots()
Dim c As Range, FirstAddress As String
With Range("a:a")
Set c = .Find("Total", LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Offset(, 5).Copy c.Offset(, 6)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End Sub[/VBA]

[Carpiem]

Hello Makako,

Terrific.... Thank you very much.

Regards,

Carpiem

[Carpiem]

Hello Malcolm,

I shouldn't be amazed, your solutions are always elegant, but I am.

Best Regards,

Brian

[mdmackillop]

Happy to help Brian,
As with most VBA, it's not necessary to select or activate cells to manipulate them, and once you avoid this, the code simplifies itself.
Regards
Malcolm