Copying non blank cells from one sheet to another

Hi all I have some code here that works great but I am looking at adding in some additions. I am currently struggling and I hope that maybe someone on here that has more experience than I would perhaps have some time to review and point me in the right direction. Here is the code that works just fine.

Sub duplicateData()
    Dim rngReadRows As Range
    Dim rngWrite As Range
    Dim rngCell As Range
    Dim timesToPaste As Integer
    Dim pasteCount As Integer
    Dim arrMonth() As Date

    'Set up the rows that we will read from
    Set rngReadRows = Sheet1.Range("A2:A10").Rows

    'Set up the first cell/row we will write to
    Set rngWrite = Sheet3.Range("A2")

    'Now loop through each row from which we will read
    For Each rngReadRow In rngReadRows.Rows

        'figure out how many times we need to paste this thing
        timesToPaste = Application.WorksheetFunction.CountA(rngReadRow.Offset(, 2).Resize(1, 13))

        'redim the date array to the size we need
        ReDim arrMonth(1 To timesToPaste)

        'Fill the array
        i = 1
        For Each rngCell In Sheet1.Range("C1:P1").Cells
            If rngReadRow.Cells(1, rngCell.Column).Value <> "" Then
                arrMonth(i) = rngCell.Value
                i = i + 1
            End If

        Next rngCell

        'Loop however many number of times
        For pasteCount = 1 To timesToPaste

            'Paste it
            rngReadRow.Resize(1, 2).Copy Destination:=rngWrite

            'Get the date (the second number in resize control how many columns data is pasted
            'set at one meaning one column. The offest is how far to the right
            rngWrite.Resize(1, 1).Offset(, 2).Value = arrMonth(pasteCount)

            'Increment to next row
            Set rngWrite = rngWrite.Offset(1)
        Next pasteCount
    Next rngReadRow
End Sub

What I am trying to do (with little success!) is add in something that would do the following:
search in Sheet1 C2:P2 and copy and transpose all non blank cells into Sheet2 starting at C2. Need to loop through each row in Sheet1, e.g. C3:P3 and so on until i reach empty row. I have tried playing with this part of code but with no luck.

Sub copyusedrange()
Dim r1 As Range
Dim r2 As Range
Dim c As Range

Set r1 = Sheets("sheet1").UsedRange.Range("b2:P2")
Set r2 = Sheets("sheet2").Range("c2")

For Each c In r1
If Len(c.Value) > 0 Then
c.copy
r2.PasteSpecial Paste:=xlPasteValues
Set r2 = r2.Offset(0, 1)
End If
Next c

Any advice/guidance/help will be very much appreciated..