VBA Copying cells based on if there is a value

Closed
Posts
11
Registration date
Sunday April 8, 2018
Status
Member
Last seen
April 19, 2018
-
I have this code which works great thanks to help I received here. I am looking to see if it is even possible to add in some addition functionality. Currently the code is doing the following. Firstly It searches C2:P2 to see if there are any values (text) if there is then it counts the number of values and Copies text from Sheet1 A2:B2 to Sheet2 A2:B2 the number of times based on the count. Secondly It also copies dates from Sheet1 C1:P1 into Sheet2 starting at C2 All of this works perfectly. I am trying to search cells in Sheet1 C2:P2 and copy in the cells that have value into Sheet2 starting at D2. So for example if Sheet1 C1 was 1/1/18 and if Sheet1 C2 was 4 then I would like to copy the '4' to Sheet2 to the next column to the right of where the date is already copied to. Code is here

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