Option Explicit
Sub trans()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long, lr2 As Long
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
Dim i As Long
Application.ScreenUpdating = False
s2.Range("A1") = s1.Range("A1")
s2.Range("B1") = "Date"
s2.Range("C1") = "qty"
With s1
For i = 2 To lr
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & i).Copy s2.Range("A" & lr2 + 1)
.Range("B1:I1").Copy
s2.Range("B" & lr2 + 1).PasteSpecial xlPasteValues, , , True
.Range("B" & i & ":I" & i).Copy
s2.Range("C" & lr2 + 1).PasteSpecial xlPasteValues, , , True
Next i
Application.CutCopyMode = False
End With
With s2
lr2 = .Range("B" & Rows.Count).End(xlUp).Row
For i = 3 To lr2
If .Range("A" & i) = "" Then .Range("A" & i) = .Range("A" & i - 1)
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Action Completed"
End Sub