Transfer data from one form to another.

Is this even possible?

Try

Option Explicit
Sub TransForm_Data()

Dim inArr() As Variant
Dim OutArr() As Variant

Dim namex As String
Dim i As Integer
Dim rr As Integer
Dim r As Long
Dim c As Long
Dim lastrow As Long
Dim lastcol As Long

Dim inRng As Range
Dim outRng As Range

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Application.ScreenUpdating = False
ws1.Activate

With ws1

    lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
    lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set inRng = .Range(.Cells(2, "B"), .Cells(lastrow, lastcol))
    
    inArr = inRng
    
    ReDim OutArr(1 To 1000, 1 To 3)
    
    rr = 0
    r = 1
    Do While r < lastrow
        
        namex = inArr(r, 1)
        For i = 1 To 5
            OutArr(rr + i, 1) = namex
            OutArr(rr + i, 2) = i
        Next i
        
        r = r + 1
        Do While inArr(r, 7) <> ""
           
            For c = 2 To 6
                  If inArr(r, c) <> "" Then
                    OutArr(rr + c - 1, 3) = inArr(r, 1)
                  End If
            Next c
            
            r = r + 1
            If r >= lastrow Then GoTo output
            
        Loop
        rr = rr + 5
    Loop
    
End With

output:
With ws2
     Set outRng = .Range(.Cells(2, 1), .Cells(rr + 6, 3))
End With

outRng = OutArr

Application.ScreenUpdating = True

End Sub

Nice, looks great, thank you very much for this. Could you just please tell me which part of the code should I change if I need more columns with date than 5? I can't figure this out.

Updated code

Option Explicit
Sub TransForm_Data()

Dim inArr() As Variant
Dim OutArr() As Variant

Dim namex As String
Dim i As Integer
Dim rr As Integer
Dim r As Long
Dim c As Long
Dim Ndates As Integer
Dim lastrow As Long
Dim lastcol As Long

Dim inRng As Range
Dim outRng As Range

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Application.ScreenUpdating = False
ws1.Activate

Ndates = 6  ' Number of dates

With ws1

    lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
    lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set inRng = .Range(.Cells(2, "B"), .Cells(lastrow, lastcol))
    
    inArr = inRng
    
    ReDim OutArr(1 To 1000, 1 To 3)
    
    rr = 0
    r = 1
    Do While r < lastrow
        
        namex = inArr(r, 1)
        For i = 1 To Ndates
            OutArr(rr + i, 1) = namex
            OutArr(rr + i, 2) = i
        Next i
        
        r = r + 1
        Do While inArr(r, Ndates + 2) <> ""
           
            For c = 2 To Ndates + 1
                  If inArr(r, c) <> "" Then
                    OutArr(rr + c - 1, 3) = inArr(r, 1)
                  End If
            Next c
            
            r = r + 1
            If r >= lastrow Then GoTo output
            
        Loop
        rr = rr + Ndates
    Loop
    
End With

output:
With ws2
     Set outRng = .Range(.Cells(2, 1), .Cells(rr + Ndates + 1, 3))
End With

outRng = OutArr

Application.ScreenUpdating = True

End Sub

Change value of "Ndates" (Highlighted)

Thank you very much!