Copy Cells above Zero and Transpose

[sarah1024]

Hello,
I’m trying to copy cells above value 0.00 in column R and S and transpose them on to column O in the same row.
Following is the snapshot of the sheet I am working with, cells in Red need to be copied and transposed on to column O. This needs to be repeated until the last populated line in column R.

N	O		P	Q	R	S
Item	Acct Amount		Expense		Freight	Pay
FUMID	14,906.56				267.35	(15,173.91)
FREIGHT					267.35	(15,173.91)
PAY					0.00	0.00
FUREG	16,367.38				316.33	(16,683.71)
FREIGHT					316.33	(16,683.71)
PAY					0.00	0.00
FUDSL	11,002.50				927.76	(11,930.26)
FUDYD	11,861.60				0.17	(11,861.77)
FREIGHT					927.93	(23,792.03)
PAY					0.00	0.00
FUDSL	11,002.50				608.08	(11,610.58)
FUDYD	11,877.30				0.16	(11,877.46)
FREIGHT					608.24	(23,488.04)
PAY					0.00	0.00

<tbody>
</tbody>

This how it should look after copy and transpose.

N	O	P	Q	R	S
Item	Acct Amount	Expense		Freight	Pay
FUMID	14,906.56			267.35	(15,173.91)
FREIGHT	267.35			267.35	(15,173.91)
PAY	(15,173.91)			0.00	0.00
FUREG	16,367.38			316.33	(16,683.71)
FREIGHT	316.33			316.33	(16,683.71)
PAY	(16,683.71)			0.00	0.00

<tbody>
</tbody>

Thank you in advance for your help!

 

[KennyGreens]

Hi, assuming you want this to be done with a macro, you can try this:

Dim i As Integer
Dim lrow As Long

lrow = Cells.Find(What:="*", after:=Range("R1"), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False).Row

For i = 1 To lrow
    If Range("R" & i).Value = 0 Then
        Range("O" & i).Offset(-1).Value = Range("R" & i).Offset(-1).Value
        Range("O" & i).Value = Range("R" & i).Offset(-1, 1).Value
    End If
Next

 

[sarah1024]

Hello Kenny,

Thank you for your quick response, but am getting Run-time error '1004'

For i = 1 To lrow If Range("R" & i).Value = 0 Then
Range("O" & i).Offset(-1).Value = Range("R" & i).Offset(-1).Value
Range("O" & i).Value = Range("R" & i).Offset(-1, 1).Value
End If
Next

End Sub

 

[Fluff]

Another option

Sub CopyTrans2()
   Dim Rng As Range
   For Each Rng In Range("O:O").SpecialCells(xlBlanks).Areas
      Rng.Value = Application.Transpose(Rng.Offset(, 3).Resize(, 2).Value)
   Next Rng
End Sub

 

[KennyGreens]

Hello Kenny,

Thank you for your quick response, but am getting Run-time error '1004'

For i = 1 To lrow If Range("R" & i).Value = 0 Then
Range("O" & i).Offset(-1).Value = Range("R" & i).Offset(-1).Value
Range("O" & i).Value = Range("R" & i).Offset(-1, 1).Value
End If
Next

End Sub

Try adding the sheet to each instance of range.

So when setting lrow declare which sheet it is, for example: Sheets(1).Cells.Find etc.

Sheets(1).Range("O" & i) etc.

 

[sarah1024]

Another option

Sub CopyTrans2()
   Dim Rng As Range
   For Each Rng In Range("O:O").SpecialCells(xlBlanks).Areas
      Rng.Value = Application.Transpose(Rng.Offset(, 3).Resize(, 2).Value)
   Next Rng
End Sub

Thank you! this worked perfectly!

 

[Fluff]

Glad we could help & thanks for the feedback