Copying non blank cells from one sheet to another

Closed
Report
Posts
11
Registration date
Sunday April 8, 2018
Status
Member
Last seen
April 19, 2018
-
Posts
11
Registration date
Sunday April 8, 2018
Status
Member
Last seen
April 19, 2018
-
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..

1 reply

Posts
2847
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
January 13, 2022
491
Hi John,

How about this code:
Sub RunMe()
Dim nRow, nCol, x As Integer

nRow = 2
nCol = 3

Sheets("Sheet1").Select

Do
    If nCol = 17 Then
        nRow = nRow + 1
        nCol = 3
        x = 0
    End If

    If Cells(nRow, nCol).Value <> vbNullString Then
        Cells(nRow, nCol).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
    Else
        x = x + 1
    End If
    
    nCol = nCol + 1
    
Loop Until x = 14

End Sub


Best regards,
Trowa
0
Posts
11
Registration date
Sunday April 8, 2018
Status
Member
Last seen
April 19, 2018

thanks I will give it a go
0