Search code examples
excelvbastringpattern-matchingtransfer

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


enter image description here

enter image description here

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

Solution

  • 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
    
    

    enter image description here