As I have a lot of time on my hands today, I decided to devote some time here. I find it a bit challenging, but in the end, it's just proper sequencing of events.
Following is the logic I employed:
- Delete all non-
Date and non-MeasureX columns.
- Store all the column names with
Measure in them in a dictionary (totally unnecessary but, hey, it's quick) as keys.
- Iterate over the keys of the first dictionary and create a second dictionary to store the date-value pairs as key-value pairs.
- Every iteration, we print out the key-value pairs in a second sheet.
Kindly read all the comments in the code as well. Also, take note of my set-up below. Finally, test this on a copy of your workbook.
Set-up:
In Sheet2, I have an unabridged data set copied roughly from your example with 1508 columns and 1500 rows of data, excluding the header. After deleting the unwanted columns, the data will be reduced to 734 columns and 1500 rows of data. On testing, the deletion takes about 11-13 seconds on my end. Your mileage may vary here.
Using this filtered data, working on it using a second dictionary takes roughly 8-9 seconds on my end to finish. The whole process basically finishes around ~20 seconds.
Screenshots:
Sheet2 (Sheet with original data):
Sheet3 (Output sheet):
Code:
Sub KamehameWave()
Dim Sht2 As Worksheet, Sht3 As Worksheet
Dim Dict As Object, Cell As Range
Dim Dict2 As Object, Cell2 As Range
Dim RngToDelete As Range
Set Sht2 = ThisWorkbook.Sheets("Sheet2") 'Modify accordingly.
Set Sht3 = ThisWorkbook.Sheets("Sheet3") 'Modify accordingly.
Application.ScreenUpdating = False
With Sht2
'-----------------------------------BK201's Notes-----------------------------------'
' The following block will delete unneeded columns. Basically, it will only keep '
' columns that either have "Date" or "MeasureX" in their headers. All else will be '
' discarded. As said in the post, do this on a copy of your worksheet. '
'-----------------------------------BK201's Notes-----------------------------------'
Start = Timer()
For Each Cell In .Rows(1).Cells
If InStr(1, Cell.Value, "Date") = 0 And InStr(1, Cell.Value, "Measure") = 0 Then
If Not RngToDelete Is Nothing Then
Set RngToDelete = Union(RngToDelete, .Columns(Cell.Column))
Else
Set RngToDelete = .Columns(Cell.Column)
End If
End If
Next Cell
RngToDelete.Delete
Debug.Print Timer() - Start
Start = Timer()
'-----------------------------------BK201's Notes-----------------------------------'
' The following block will create a dictionary and store all the names of columns '
' with "Measure" in them. This is just so you have a reference. An array or a '
' collection will do as well. I prefer to use this though as I find it easier. '
'-----------------------------------BK201's Notes-----------------------------------'
Set Dict = CreateObject("Scripting.Dictionary")
For Each Cell In .Rows(1).Cells
CheckIfMeasure = InStr(1, Cell.Value, "Measure")
If CheckIfMeasure > 0 Then
If Not Dict.Exists(Cell.Value) And Not IsEmpty(Cell.Value) Then
Dict.Add Cell.Value, Empty
End If
End If
Next Cell
'-----------------------------------BK201's Notes-----------------------------------'
' What we'll do next is to iterate over each "MeasureX" column. We'll iterate over '
' the values on these columns and store them in a *second* dictionary, with their '
' respective dates being the keys. '
'-----------------------------------BK201's Notes-----------------------------------'
For Each Key In Dict
MColIndex = Application.Match(Key, .Rows(1), 0)
MColLRow = .Cells(Rows.Count, MColIndex).End(xlUp).Row
Set MCol = .Range(.Cells(2, MColIndex), .Cells(MColLRow, MColIndex))
Set Dict2 = CreateObject("Scripting.Dictionary")
For Each Cell2 In MCol
If Not Dict2.Exists(Cell2.Value) And Not IsEmpty(Cell2.Value) Then
Dict2.Add Cell2.Offset(0, -1).Value, Cell2.Value
End If
Next Cell2
'-----------------------------------BK201's Notes-----------------------------------'
' The final phase is to get the next empty row in the output sheet and dump all the '
' key-value pairs from our second dictionary there. Since we're also iterating '
' through the keys of the first dictionary, the list will append properly to '
' accommodate each key's own dictionary. '
'-----------------------------------BK201's Notes-----------------------------------'
TColNRow = Sht3.Range("A" & Rows.Count).End(xlUp).Row + 1
Sht3.Range("A" & TColNRow).Resize(Dict2.Count, 1).Value = Application.Transpose(Dict2.Keys)
Sht3.Range("B" & TColNRow).Resize(Dict2.Count, 1).Value = Key
Sht3.Range("C" & TColNRow).Resize(Dict2.Count, 1).Value = Application.Transpose(Dict2.Items)
Next Key
Debug.Print Timer() - Start
End With
Application.ScreenUpdating = True
End Sub
Results after running the code:
First number is runtime of deletion, second is for the transposition. Not bad considering that I am at half a million data points. Sorting the data is on your court.
Let us know if this helps.
