Add 5 rows for each row using VBA Macros - excel

Question

Hi All i have two worksheets from Sheet1 i am copying to Sheet2 which copy data to each row once now i want my data should be look like "To be Version" :
First column will be repeated 5 time and other column should be only once i am trying but it does not working ..
I am using Macros to do this
Function getLastRow(targetSheet As Worksheet, colLetter As String) As Integer
Dim lastRow As Integer
With targetSheet
getLastRow = .Cells(.Rows.count, colLetter).End(xlUp).Row
End With
End Function
Function getColumn(targetSheet As Worksheet, FindWord As String, Optional iRow As Integer = 1) As Integer
Dim iCol As Integer
Dim tmpString As String
For iCol = 1 To getLastColumn(targetSheet, 2)
'targetSheet.Activate
tmpString = VBA.Replace(targetSheet.Cells(iRow, iCol).Value, "", "")
If VBA.InStr(1, VBA.LCase(tmpString), VBA.Replace(VBA.LCase(FindWord), "", "")) Then
getColumn = iCol
Exit Function
End If
Next iCol
End Function
Sub ProcFile()
Dim wsRaw As Worksheet: Set wsRaw = ThisWorkbook.Sheets("Sheet1")
Dim wsAR As Worksheet: Set wsAR = ThisWorkbook.Sheets("Sheet2")
Dim iRow, x, LRow, sRow, col As Long
Dim Tes1, Test2, Test3 As String
sRow = getLastRow(wsAR, "E") + 1
LRow = getLastRow(wsRaw, "A")
If wsRaw.Range("A2").Value = "" Then MsgBox "Raw Data tab is Empty!!", vbCritical: Exit Sub
For x = 2 To LRow
Tes1 = wsRaw.Cells(x, getColumn(wsRaw, "Tes1")).Value
Test2 = wsRaw.Cells(x, getColumn(wsRaw, "Test2")).Value
Test3 = wsRaw.Cells(x, getColumn(wsRaw, "Test3")).Value
For col = 3 To 45 Step 2
If wsRaw.Cells(x, col).Value <> "" Then
wsAR.Range("A" & sRow).Value = Tes1
wsAR.Range("B" & sRow).Value = Test2
wsAR.Range("C" & sRow).Value = Test3
End If
Next col
sRow = sRow + 1
Next x
MsgBox "Done!!"
End Sub
Sheet 1 Raw Data
Sheet 2 Data in after macro excution
The Data i am getting in my Macro excution:

Answer 1

Repeat Rows
Quick Help (Not tested)
Replace the line
sRow = sRow + 1
with
sRow = sRow + 5
Instead of the lines:
wsAR.Range("A" & sRow).Value = Tes1
wsAR.Range("B" & sRow).Value = Test2
wsAR.Range("C" & sRow).Value = Test3
use the following:
wsAR.Range("B" & sRow).Value = Test2
wsAR.Range("C" & sRow).Value = Test3
For sRow = sRow To sRow + 4
wsAR.Range("A" & sRow).Value = Test1
Next sRow
sRow = sRow - 5
Initial Answer
The following will overwrite a range in the following way:
The first row (the headers) stays the same.
Every value in the first column will be written five times, one below the other.
The remaining columns will be written only once leaving four empty cells below.
Option Explicit
Sub repeatRows()
Const wsName As String = "Sheet2"
Const RowsCount As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim rg As Range: Set rg = wb.Worksheets(wsName).Range("A1").CurrentRegion
Dim Data As Variant: Data = rg.Value
Dim srCount As Long: srCount = UBound(Data, 1)
Dim cCount As Long: cCount = UBound(Data, 2)
Dim drCount As Long: drCount = (srCount - 1) * (RowsCount + 1) + 1
Dim Result As Variant: ReDim Result(1 To drCount, 1 To cCount)
Dim c As Long
For c = 1 To cCount
Result(1, c) = Data(1, c)
Next c
Dim n As Long: n = 1
Dim r As Long, i As Long
For r = 2 To srCount
n = n + 1
For c = 1 To cCount
Result(n, c) = Data(r, c)
Next c
For i = 1 To RowsCount
n = n + 1
Result(n, 1) = Data(r, 1)
Next i
Next r
rg.Resize(n).Value = Result
End Sub