Sub fillCells()
Dim wst As Worksheet
Dim title As Variant, rncArr As Variant, dataRange As Variant
Dim maxDate As Date, minDate As Date
Dim i As Integer, j As Integer, row As Integer, endRow As Integer
Set wst = Worksheets("Sheet5")
title = Array("RNC", "Date", "S1", "S2", "S3", "S4", "S5", "S6", "S7", "S8", "S9")
rncArr = Array("RNC1", "RNC2", "RNC3", "RNC4", "RNC5", "RNC6", "RNC7", "RNC8", "RNC9", "RNC10")
minDate = #7/20/2010#
maxDate = #9/27/2010#
row = 1
wst.Range(wst.Cells(1, 1), wst.Cells(1, UBound(title) + 1)) = title
endRow = (UBound(rncArr) + 1) * (maxDate - minDate + 1) + 1
dataRange = wst.Range(wst.Cells(2, 1), wst.Cells(endRow, 2)).Value
For i = 1 To UBound(rncArr) + 1
For j = 1 To (maxDate - minDate + 1)
dataRange(row, 1) = rncArr(i - 1)
dataRange(row, 2) = minDate + j - 1
row = row + 1
Next j
Next i
wst.Range(wst.Cells(2, 1), wst.Cells(endRow, 2)).Value = dataRange
End Sub