With excel vba, transferring data to another page with a specific pattern

Question

I would like to transfer the values selected by users from dropdown lists locating within the range B4:M29 to the range B6:G56 on another sheet with a specific pattern. With this pattern, the values in 'B' column/sheet1 will be header in 'A' column/sheet5 then the remaining consecutive values will be transferred as they follows each other by moving to the next line from the middle. As I try to show schematically below:

Sub Group6_Click()

   Dim wSheet As Worksheet

    Dim vFile As Variant

    Dim sFile As String

    Dim j As String

    Dim wb As Workbook

   

    Dim OldData As Range

    Dim NewData As Range

    Set OldData = ThisWorkbook.Sheets("sheet1").Range("B4:M29")

    Set NewData = ThisWorkbook.Sheets("sheet5").Range("A6:L31")

    Set wb = ThisWorkbook

        OldData.Value = NewData.Value

 

    Set wSheet = ActiveSheet

    sFile = Replace(Replace(wb.Name, "KV_Envanter", ""), ".", "_") _

            & "_" _

            & Format(Now(), "yyyymmdd\_hhmm") _

            & ".pdf"

    sFile = ThisWorkbook.Path & "\" & sFile

 

    vFile = Application.GetSaveAsFilename _

    (InitialFileName:=sFile, _

        FileFilter:="PDF Files (*.pdf), *.pdf", _

        Title:="Select Folder and FileName to save")

 

    If vFile <> "False" Then

 

MsgBox "The report is ready."

Sheets("sheet5").ExportAsFixedFormat Type:=xlTypePDF, _

Filename:=vFile, Quality:=xlQualityStandard, _

IncludeDocProperties:=True, IgnorePrintAreas:=False, _

OpenAfterPublish:=True

 

Sheets("sheet5").PageSetup.Orientation = xlLandscape

 

With ActiveSheet.PageSetup

    .LeftMargin = Application.InchesToPoints(0)

   .RightMargin = Application.InchesToPoints(0)

    .TopMargin = Application.InchesToPoints(0)

    .BottomMargin = Application.InchesToPoints(0)

    .FitToPagesWide = 1

End With

  

    End If

 

End Sub

Answer 1

Option Explicit
Sub demo()
    Dim oldData As Range, arrData, arrRes()
    Dim newData As Range
    Dim newColCnt As Integer, i As Long, j As Long, k As Long
    Dim oldColCnt As Integer
    ' Load data
    Set oldData = ThisWorkbook.Sheets("sheet1").Range("B4:M29")
    arrData = oldData
    ' redim array for new data
    oldColCnt = UBound(arrData, 2)
    newColCnt = oldColCnt / 2 + 1
    ReDim arrRes(1 To UBound(arrData) * 2, 1 To newColCnt)
    k = 1
    ' Loop through each row to transform data
    For i = 1 To UBound(arrData)
        For j = 1 To newColCnt Step 1
            arrRes(k, j) = arrData(i, j)
            If j > 1 And j + newColCnt < oldColCnt + 2 Then
                arrRes(k + 1, j) = arrData(i, j + newColCnt - 1)
            End If
        Next
        k = k + 2
    Next
    ' Write new data to sheet
    Set newData = ThisWorkbook.Sheets("sheet5").Range("A6")
    newData.Resize(UBound(arrData) * 2, newColCnt).Value = arrRes
End Sub