Помогите написать макрос

[Pys]

Добрый вечер! Прошу помощи у специалистов, написать макрос который из исходных данных тянул таблицу по шаблону (2 вкладка"нужно получить").

Буду очень признательна.

[Aleksandr H.]

Тупой перебор ячеек

Sub smth()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim r As Integer, r1 As Integer, c As Integer, c1 As Integer
    Application.EnableCancelKey = xlDisabled    ' Fix for Code execution has been interrupted
    Application.ScreenUpdating = False
    Set ws = Sheets("Исходные данные")
    Set ws1 = Sheets("Лист3")
    r = 2: r1 = 2
    c1 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For c = 6 To c1
        Do While ws.Cells(r, "A") <> ""
            If ws.Cells(r, c) <> "" Then
                ws.Range("A" & r & ":C" & r).Copy
                ws1.Range("B" & r1).PasteSpecial (xlPasteAll)
                ws1.Range("E" & r1) = ws.Range("E" & r)
                ws1.Range("A" & r1) = Format(ws.Cells(1, c), "dd.mm.yyyy")
                ws1.Range("F" & r1) = ws.Cells(r, c)
                r1 = r1 + 1
            End If
            r = r + 1
        Loop
        r = 2
    Next
    Set ws = Nothing
    Set ws1 = Nothing
    
    Application.ScreenUpdating = True
End Sub