Option Explicit
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Dim aStartTime
Const DblSpace As String = vbNewLine & vbNewLine
Const SpecialCharacters As String = "!,?,@,#,$,%,^,&,*,(,),{,[,],}" 'modify as needed
Dim strFullName As String
Dim ProcName As String
Dim bErrorHandle As Boolean
Dim SourceWbk As Workbook
Sub Test()
Dim lRow As Long, lCol As Long
Dim RepeatColsCount As Long
Dim rngDel As Range
Dim ActWbk As Workbook
Dim UserRange As Range
On Error GoTo errHandler
bErrorHandle = False
'~~> Start Timer
aStartTime = Now()
Set SourceWbk = ActiveWorkbook
On Error Resume Next
Set UserRange = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Default:=Selection.Address, Type:=8)
If UserRange Is Nothing Then
MsgBox "You press Cancel, this procedure will now terminate."
Exit Sub
End If
redo:
Dim v As Variant
v = Application.InputBox(Prompt:="How many columns, at the left side will repeat?", Title:="Input Whole Numbers Only", Type:=1)
If v = "False" Then
bErrorHandle = True
MsgBox "Terminate Processing", vbCritical
GoTo BeforeExit
End If
'<~~ More Testing for positive Integer only
If v < 1 Or Not (v = Int(v)) Then
MsgBox "How many columns are needed - this must be a postive integer?", vbCritical
GoTo redo
End If
RepeatColsCount = Int(v)
'~~> Speeding Up VBA Code
Call SpeedUp(False)
Call NormalizeList(UserRange, RepeatColsCount, "Period", "Value", True)
'~~> New UnPivot Data workbook
Set ActWbk = ActiveWorkbook
'~~>
Call SaveAs(ActWbk)
BeforeExit:
'~~> Remove items from memory
Set ActWbk = Nothing
Set SourceWbk = Nothing
Set rngDel = Nothing
'~~> Speeding Up VBA Code
Call SpeedUp(True)
If bErrorHandle = False Then
MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine _
& DblSpace & " You're good to go!" & DblSpace & _
"UnPivot Done" & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
'~~> Close Workbook with VBA Code too
ThisWorkbook.Close False
End If
Exit Sub
errHandler:
'~~> Error Occurred
bErrorHandle = True
ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
Resume BeforeExit
End Sub
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(After:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
Private Sub SaveAs(wbDestination As Workbook)
Dim strFile As String
Dim NewFile As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim bIsDirectoryExist As Boolean
Const ANewString As String = "Data"
Const newFolder As String = "UnPivot Data Files"
Const sExt As String = ".xlsx"
On Error GoTo errHandler
'~~> Speeding Up VBA Code
Call SpeedUp(False)
With wbDestination
NewFile = Left(.Name, Len(.Name) - 5) & ANewString
FileExtStr = sExt
'~~> Checks If Directory Exists
bIsDirectoryExist = IsDirectoryExist(SourceWbk.Path & Application.PathSeparator & newFolder)
Select Case FileExtStr
Case ".xlsb": FileFormatNum = 50
Case ".xlsx": FileFormatNum = 51
Case ".xlsm": FileFormatNum = 52
Case ".xls": FileFormatNum = 56
Case ".csv": FileFormatNum = 6
Case ".txt": FileFormatNum = -4158
Case ".prn": FileFormatNum = 36
Case Else: FileFormatNum = 0
End Select
'Now we can create/Save the file with the xlFileFormat parameter
'value that match the file extension
If FileFormatNum = 0 Then
MsgBox "Sorry, unknown file extension"
Else
'~~> Delete Parameters worksheet tab
On Error Resume Next
Sheets("Parameters").Delete
On Error GoTo 0
'~~> Saveas default file path location
.SaveAs Filename:=SourceWbk.Path & Application.PathSeparator & newFolder & Application.PathSeparator & NewFile & " " & Format(Now(), "yyyy-MM-dd hh-mm-ss"), FileFormat:=FileFormatNum
'~~> Save and close new file
.Saved = True
.Close
End If
End With
BeforeExit:
'~~> Remove items from memory
Set wbDestination = Nothing
'~~> Speeding Up VBA Code
Call SpeedUp(True)
' If bErrorHandle = False Then
' MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine _
' & DblSpace & " You're good to go!" & DblSpace & _
' "Job Done! " & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
' End If
Exit Sub
errHandler:
'~~> Error Occurred
bErrorHandle = True
ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
Resume BeforeExit
End Sub
