Sub TransferData()
Dim lastRow As Long
Dim recRow As Long
Dim i As Long
Dim destWS As Worksheet
Dim sourceWS As Worksheet
Application.ScreenUpdating = False
Set sourceWS = Worksheets("Sheet1")
Set destWS = Worksheets.Add(after:=sourceWS)
''Setup the header row
With destWS
.Range("A1").Value = "Number"
.Range("B1").Value = "Element"
.Range("C1").Value = "Type"
.Range("D1").Value = "Value1"
End With
recRow = 2
With sourceWS
lastRow = .Range("A1").End(xlDown).Row
For i = 2 To lastRow
destWS.Cells(recRow, 1).Resize(4, 1).Value = .Cells(i, 1).Value
'Magic values, since you didn't tell me where they come from! :(
destWS.Cells(recRow, 2).Value = "ABC"
destWS.Cells(recRow + 1, 2).Value = "XYZ"
destWS.Cells(recRow + 2, 2).Value = "ABC 12.5"
destWS.Cells(recRow + 3, 2).Value = "XYZ 12.5"
'More magic values
destWS.Cells(recRow, 3).Value = "A1"
destWS.Cells(recRow + 1, 3).Value = "X1"
destWS.Cells(recRow + 2, 3).Value = "A1 12.5"
destWS.Cells(recRow + 3, 3).Value = "X1 12.5"
'Perform calculations
destWS.Cells(recRow, 4) = .Cells(i, 3)
destWS.Cells(recRow + 1, 4) = .Cells(i, 4)
destWS.Cells(recRow + 2, 4) = .Cells(i, 3) * 0.125
destWS.Cells(recRow + 3, 4) = .Cells(i, 4) * 0.125
recRow = recRow + 4
Next i
End With
Application.ScreenUpdating = True
End Sub