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
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