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.
[TABLE="width: 579"]
<tbody>[TR]
[TD]
N
[/TD]
[TD]O
[/TD]
[TD]
[/TD]
[TD]P
[/TD]
[TD]Q
[/TD]
[TD]R
[/TD]
[TD]S
[/TD]
[/TR]
[TR]
[TD]Item
[/TD]
[TD]Acct Amount
[/TD]
[TD]
[/TD]
[TD]Expense
[/TD]
[TD][/TD]
[TD]Freight
[/TD]
[TD]Pay
[/TD]
[/TR]
[TR]
[TD]FUMID
[/TD]
[TD]14,906.56
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]267.35
[/TD]
[TD](15,173.91)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]267.35
[/TD]
[TD](15,173.91)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
[TR]
[TD]FUREG
[/TD]
[TD]16,367.38
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]316.33
[/TD]
[TD](16,683.71)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]316.33
[/TD]
[TD](16,683.71)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
[TR]
[TD]FUDSL
[/TD]
[TD]11,002.50
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]927.76
[/TD]
[TD](11,930.26)
[/TD]
[/TR]
[TR]
[TD]FUDYD
[/TD]
[TD]11,861.60
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.17
[/TD]
[TD](11,861.77)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]927.93
[/TD]
[TD](23,792.03)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
[TR]
[TD]FUDSL
[/TD]
[TD]11,002.50
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]608.08
[/TD]
[TD](11,610.58)
[/TD]
[/TR]
[TR]
[TD]FUDYD
[/TD]
[TD]11,877.30
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.16
[/TD]
[TD](11,877.46)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]608.24
[/TD]
[TD](23,488.04)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD][/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
</tbody>[/TABLE]

This how it should look after copy and transpose.
[TABLE="width: 580"]
<tbody>[TR]
[TD]N
[/TD]
[TD]O
[/TD]
[TD]P
[/TD]
[TD]Q
[/TD]
[TD]R
[/TD]
[TD]S
[/TD]
[/TR]
[TR]
[TD]Item
[/TD]
[TD]Acct Amount
[/TD]
[TD]Expense
[/TD]
[TD][/TD]
[TD]Freight
[/TD]
[TD]Pay
[/TD]
[/TR]
[TR]
[TD]FUMID
[/TD]
[TD]14,906.56
[/TD]
[TD][/TD]
[TD][/TD]
[TD]267.35
[/TD]
[TD](15,173.91)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD]267.35
[/TD]
[TD][/TD]
[TD][/TD]
[TD]267.35
[/TD]
[TD](15,173.91)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD](15,173.91)
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
[TR]
[TD]FUREG
[/TD]
[TD]16,367.38
[/TD]
[TD][/TD]
[TD][/TD]
[TD]316.33
[/TD]
[TD](16,683.71)
[/TD]
[/TR]
[TR]
[TD]FREIGHT
[/TD]
[TD]316.33
[/TD]
[TD][/TD]
[TD][/TD]
[TD]316.33
[/TD]
[TD](16,683.71)
[/TD]
[/TR]
[TR]
[TD]PAY
[/TD]
[TD](16,683.71)
[/TD]
[TD][/TD]
[TD][/TD]
[TD]0.00
[/TD]
[TD]0.00
[/TD]
[/TR]
</tbody>[/TABLE]

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