I'm looking for a way to have three different colors in the same line chart of a diagram in Excel, depending on the values themselves or where they are from (from which sheet f.e).
Till now, I have the following code:
Sub ChangeColor()
Dim i As Integer
Dim IntRow As Integer
Dim r As Range
ActiveSheet.ChartObjects("Cash").Activate
ActiveChart.SeriesCollection(1).Select
IntRow = ActiveChart.ChartObjects("Cash").Count
For i = 2 To IntRow
Set r = Cells(2, i)
If r.Value < 3000 Then
Selection.Border.ColorIndex = 5
Else
Selection.Border.ColorIndex = 9
End If
Next
End Sub
However, the if statement is not considered and the color of the whole line changes only whenever I change the first ColorIndex. I have no idea, how to color parts of the line depending on the values in the underlying table.
Moreover, by defining IntRow as ActiveChart.ChartObjects("Cash").Count I'm not able to get the length of my array. This problem can be solved by manual counting and declaring IntRow as an Integer, however, the version above seems nicer (if that is possible of course).
I appreciate any help! Thank you.
Alexandra
You can read the values directly from the chart series:
Sub ChangeColor()
Dim cht As Chart, p As Point, s As Series
Dim i As Integer
Dim numPts As Long
'access the chart directly - no select/activate required
Set cht = ActiveSheet.ChartObjects("Cash").Chart
'reference the first series
Set s = cht.SeriesCollection(1)
'how many points in the first series?
numPts = s.Points.Count
'loop over the series points
For i = 1 To numPts
Set p = cht.SeriesCollection(1).Points(i)
p.Border.ColorIndex = IIf(s.Values(i) < 3000, 5, 9)
Next
End Sub
I am writing a VBA code that goes through a defined matrix size and filling cells randomly within its limits.
I got the code here from a user on stackoverflow, but after testing it I realized that it does not fit for avoiding duplicate filling, and for instance when filling 5 cells, I could only see 4 cells filled, meaning that the random filling worked on a previously filled cell.
This is the code I'm working with:
Dim lRandom As Long
Dim sCells As String
Dim sRandom As String
Dim rMolecules As Range
Dim i As Integer, j As Integer
Dim lArea As Long
lArea = 400 '20x20
'Populate string of cells that make up the container so they can be chosen at random
For i = 1 To 20
For j = 1 To 20
sCells = sCells & "|" & Cells(i, j).Address
Next j
Next i
sCells = sCells & "|"
'Color the molecules at random
For i = 1 To WorksheetFunction.Min(5, lArea)
Randomize
lRandom = Int(Rnd() * 400) + 1
sRandom = Split(sCells, "|")(lRandom)
Select Case (i = 1)
Case True: Set rMolecules = Range(sRandom)
Case Else: Set rMolecules = Union(rMolecules, Range(Split(sCells, "|")(lRandom)))
End Select
sCells = Replace(sCells, "|" & sRandom & "|", "|")
lArea = lArea - 1
Next i
rMolecules.Interior.ColorIndex = 5
Using this same exact code which works perfectly, WHAT can I insert and WHERE do I do that so that the code would check if a cell is previously already filled with a string or a color?
I feel as though this code I'm looking for should be right before
rMolecules.Interior.ColorIndex = 5
But I'm not sure what to type.
EDIT
From the comments I realized that I should be more specific.
I am trying to randomly fill cells with the blue color (.ColorIndex = 5), but what I need to check first is if the randomizing hadn't marked a cell twice, so that for instance in this case, if I want to mark 5 different cells, it marks only 4 of them because of a duplicate and thus fills only 4 cells with the blue color. I need to avoid that and make it choose another cell to mark/fill.
I'd appreciate your help.
Keep the cells you use in a Collection and remove them as you fill the random cells:
Sub FillRandomCells(targetRange As Range, numberOfCells As Long)
' populate collection of unique cells
Dim c As Range
Dim targetCells As New Collection
' make sure arguments make sense
If numberOfCells > targetRange.Cells.Count Then
Err.Raise vbObjectError, "FillRandomCells()", _
"Number of cells to be changed can not exceed number of cells in range"
End If
For Each c In targetRange.Cells
targetCells.Add c
Next
' now pick random 5
Dim i As Long, randomIndex As Long
Dim upperbound As Long
Dim lowerbound As Long
For i = 1 To numberOfCells
lowerbound = 1 ' collections start with 1
upperbound = targetCells.Count ' changes as we are removing cells we used
randomIndex = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Set c = targetCells(randomIndex)
targetCells.Remove randomIndex ' remove so we don't use it again!
c.Interior.Color = 5 ' do what you need to do here
Next
End Sub
Sub testFillRandomCells()
FillRandomCells ActiveSheet.[a1:t20], 5
FillRandomCells ActiveSheet.[b25:f30], 3
End Sub
EDIT: Changed to make the target range and number of changed cells configurable as arguments to a function. Also added error checking (always do that!).
Why not build a list of random numbers and place in a Scripting.Dictionary, one can use the Dictionary's Exist method to detect duplicates, loop through until you have enough then you can enter your colouring code confident that you have a unique list.
I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.
I have two bits of code. First a standard copy paste from cell A to cell B
Sheets(sheet_).Cells(x, 1).Copy Destination:=Sheets("Output").Cells(startrow, 2)
I can do almost the same using
Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Now this second method is much faster, avoiding copying to clipboard and pasting again. However it does not copy across the formatting as the first method does. The Second version is almost instant to copy 500 lines, while the first method adds about 5 seconds to the time. And the final version could be upwards of 5000 cells.
So my question can the second line be altered to included the cell formatting (mainly font colour) while still staying fast.
Ideally I would like to be able to copy the cell values to a array/list along with the font formatting so I can do further sorting and operations on them before I "paste" them back on to the worksheet..
So my ideal solution would be some thing like
for x = 0 to 5000
array(x) = Sheets(sheet_).Cells(x, 1) 'including formatting
next
for x = 0 to 5000
Sheets("Output").Cells(x, 1)
next
is it possible to use RTF strings in VBA or is that only possible in vb.net, etc.
Answer*
Just to see how my origianl method and new method compar, here are the results or before and after
New code = 65msec
Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Sheets("Output").Range("B" & startrow).Font.ColorIndex = Sheets(sheet_).Range("A" & x).Font.ColorIndex 'copy font colour as well
Old code = 1296msec
'Sheets("Output").Cells(startrow, 2).Value = Sheets(sheet_).Cells(x, 1)
'Sheets(sheet_).Cells(x, 1).Copy
'Sheets("Output").Cells(startrow, 2).PasteSpecial (xlPasteFormats)
'Application.CutCopyMode = False
You could have simply used Range("x1").value(11)
something like below:
Sheets("Output").Range("$A$1:$A$500").value(11) = Sheets(sheet_).Range("$A$1:$A$500").value(11)
range has default property "Value" plus value can have 3 optional orguments 10,11,12.
11 is what you need to tansfer both value and formats. It doesn't use clipboard so it is faster.- Durgesh
For me, you can't. But if that suits your needs, you could have speed and formatting by copying the whole range at once, instead of looping:
range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)
And, by the way, you can build a custom range string, like Range("B2:B4, B6, B11:B18")
edit: if your source is "sparse", can't you just format the destination at once when the copy is finished ?
Remember that when you write:
MyArray = Range("A1:A5000")
you are really writing
MyArray = Range("A1:A5000").Value
You can also use names:
MyArray = Names("MyWSTable").RefersToRange.Value
But Value is not the only property of Range. I have used:
MyArray = Range("A1:A5000").NumberFormat
I doubt
MyArray = Range("A1:A5000").Font
would work but I would expect
MyArray = Range("A1:A5000").Font.Bold
to work.
I do not know what formats you want to copy so you will have to try.
However, I must add that when you copy and paste a large range, it is not as much slower than doing it via an array as we all thought.
Post Edit information
Having posted the above I tried by own advice. My experiments with copying Font.Color and Font.Bold to an array have failed.
Of the following statements, the second would fail with a type mismatch:
ValueArray = .Range("A1:T5000").Value
ColourArray = .Range("A1:T5000").Font.Color
ValueArray must be of type variant. I tried both variant and long for ColourArray without success.
I filled ColourArray with values and tried the following statement:
.Range("A1:T5000").Font.Color = ColourArray
The entire range would be coloured according to the first element of ColourArray and then Excel looped consuming about 45% of the processor time until I terminated it with the Task Manager.
There is a time penalty associated with switching between worksheets but recent questions about macro duration have caused everyone to review our belief that working via arrays was substantially quicker.
I constructed an experiment that broadly reflects your requirement. I filled worksheet Time1 with 5000 rows of 20 cells which were selectively formatted as: bold, italic, underline, subscript, bordered, red, green, blue, brown, yellow and gray-80%.
With version 1, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" using copy.
With version 2, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the value and the colour via an array.
With version 3, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the formula and the colour via an array.
Version 1 took an average of 12.43 seconds, version 2 took an average of 1.47 seconds while version 3 took an average of 1.83 seconds. Version 1 copied formulae and all formatting, version 2 copied values and colour while version 3 copied formulae and colour. With versions 1 and 2 you could add bold and italic, say, and still have some time in hand. However, I am not sure it would be worth the bother given that copying 21,300 values only takes 12 seconds.
** Code for Version 1**
I do not think this code includes anything that needs an explanation. Respond with a comment if I am wrong and I will fix.
Sub SelectionCopyAndPaste()
Dim ColDestCrnt As Integer
Dim ColSrcCrnt As Integer
Dim NumSelect As Long
Dim RowDestCrnt As Integer
Dim RowSrcCrnt As Integer
Dim StartTime As Single
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
NumSelect = 1
ColDestCrnt = 1
RowDestCrnt = 1
With Sheets("Time2")
.Range("A1:T715").EntireRow.Delete
End With
StartTime = Timer
Do While True
ColSrcCrnt = (NumSelect Mod 20) + 1
RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
If RowSrcCrnt > 5000 Then
Exit Do
End If
Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
If ColDestCrnt = 20 Then
ColDestCrnt = 1
RowDestCrnt = RowDestCrnt + 1
Else
ColDestCrnt = ColDestCrnt + 1
End If
NumSelect = NumSelect + 7
Loop
Debug.Print Timer - StartTime
' Average 12.43 secs
Application.Calculation = xlCalculationAutomatic
End Sub
** Code for Versions 2 and 3**
The User type definition must be placed before any subroutine in the module. The code works through the source worksheet copying values or formulae and colours to the next element of the array. Once selection has been completed, it copies the collected information to the destination worksheet. This avoids switching between worksheets more than is essential.
Type ValueDtl
Value As String
Colour As Long
End Type
Sub SelectionViaArray()
Dim ColDestCrnt As Integer
Dim ColSrcCrnt As Integer
Dim InxVLCrnt As Integer
Dim InxVLCrntMax As Integer
Dim NumSelect As Long
Dim RowDestCrnt As Integer
Dim RowSrcCrnt As Integer
Dim StartTime As Single
Dim ValueList() As ValueDtl
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' I have sized the array to more than I expect to require because ReDim
' Preserve is expensive. However, I will resize if I fill the array.
' For my experiment I know exactly how many elements I need but that
' might not be true for you.
ReDim ValueList(1 To 25000)
NumSelect = 1
ColDestCrnt = 1
RowDestCrnt = 1
InxVLCrntMax = 0 ' Last used element in ValueList.
With Sheets("Time2")
.Range("A1:T715").EntireRow.Delete
End With
StartTime = Timer
With Sheets("Time1")
Do While True
ColSrcCrnt = (NumSelect Mod 20) + 1
RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
If RowSrcCrnt > 5000 Then
Exit Do
End If
InxVLCrntMax = InxVLCrntMax + 1
If InxVLCrntMax > UBound(ValueList) Then
' Resize array if it has been filled
ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
End If
With .Cells(RowSrcCrnt, ColSrcCrnt)
ValueList(InxVLCrntMax).Value = .Value ' Version 2
ValueList(InxVLCrntMax).Value = .Formula ' Version 3
ValueList(InxVLCrntMax).Colour = .Font.Color
End With
NumSelect = NumSelect + 7
Loop
End With
With Sheets("Time2")
For InxVLCrnt = 1 To InxVLCrntMax
With .Cells(RowDestCrnt, ColDestCrnt)
.Value = ValueList(InxVLCrnt).Value ' Version 2
.Formula = ValueList(InxVLCrnt).Value ' Version 3
.Font.Color = ValueList(InxVLCrnt).Colour
End With
If ColDestCrnt = 20 Then
ColDestCrnt = 1
RowDestCrnt = RowDestCrnt + 1
Else
ColDestCrnt = ColDestCrnt + 1
End If
Next
End With
Debug.Print Timer - StartTime
' Version 2 average 1.47 secs
' Version 3 average 1.83 secs
Application.Calculation = xlCalculationAutomatic
End Sub
Just use the NumberFormat property after the Value property:
In this example the Ranges are defined using variables called ColLetter and SheetRow and this comes from a for-next loop using the integer i, but they might be ordinary defined ranges of course.
TransferSheet.Range(ColLetter & SheetRow).Value = Range(ColLetter & i).Value
TransferSheet.Range(ColLetter & SheetRow).NumberFormat = Range(ColLetter & i).NumberFormat
Does:
Set Sheets("Output").Range("$A$1:$A$500") = Sheets(sheet_).Range("$A$1:$A$500")
...work? (I don't have Excel in front of me, so can't test.)
I have a two dimensional table with countries and years in Excel. eg.
1961 1962 1963 1964
USA a x g y
France u e h a
Germany o x n p
I'd like to "flatten" it, such that I have Country in the first col, Year in the second col, and then value in the third col. eg.
Country Year Value
USA 1961 a
USA 1962 x
USA 1963 g
USA 1964 y
France 1961 u
...
The example I present here is only a 3x4 matrix, but the real dataset i have is significantly larger (roughly 50x40 or so).
Any suggestions how I can do this using Excel?
You can use the excel pivot table feature to reverse a pivot table (which is essentially what you have here):
Good instructions here:
http://spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/
Which links to the following VBA code (put it in a module) if you don't want to follow the instructions by hand:
Sub ReversePivotTable()
' Before running this, make sure you have a summary table with column headers.
' The output table will have three columns.
Dim SummaryTable As Range, OutputRange As Range
Dim OutRow As Long
Dim r As Long, c As Long
On Error Resume Next
Set SummaryTable = ActiveCell.CurrentRegion
If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
MsgBox "Select a cell within the summary table.", vbCritical
Exit Sub
End If
SummaryTable.Select
Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
' Convert the range
OutRow = 2
Application.ScreenUpdating = False
OutputRange.Range("A1:C3") = Array("Column1", "Column2", "Column3")
For r = 2 To SummaryTable.Rows.Count
For c = 2 To SummaryTable.Columns.Count
OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
OutRow = OutRow + 1
Next c
Next r
End Sub
-Adam
In Excel 2013 need to follow next steps:
select data and convert to table (Insert -> Table)
call Query Editor for table (Power Query -> From Table)
select columns that contain years
in context menu select 'Unpivot Columns'-command.
Support Office: Unpivot columns (Power Query)
In Excel 2016, Power Query is called Get & Transform and it is found in the Data tab.
#Adam Davis's answer is perfect, but just in case you're as clueless as I am about Excel VBA, here's what I did to get the code working in Excel 2007:
Open the workbook with the Matrix that needs to be flattened to a table and navigate to that worksheet
Press Alt-F11 to open the VBA code editor.
On the left pane, in the Project box, you'll see a tree structure representing the excel objects and any code (called modules) that already exist. Right click anywhere in the box and select "Insert->Module" to create a blank module file.
Copy and paste #Adman Davis's code from above as is into the blank page the opens and save it.
Close the VBA editor window and return to the spreadsheet.
Click on any cell in the matrix to indicate the matrix you'll be working with.
Now you need to run the macro. Where this option is will vary based on your version of Excel. As I'm using 2007, I can tell you that it keeps its macros in the "View" ribbon as the farthest right control. Click it and you'll see a laundry list of macros, just double click on the one called "ReversePivotTable" to run it.
It will then show a popup asking you to tell it where to create the flattened table. Just point it to any empty space an your spreadsheet and click "ok"
You're done! The first column will be the rows, the second column will be the columns, the third column will be the data.
Flattening a data matrix (aka Table) can be accomplished with one array formula¹ and two standard formulas.
The array formula¹ and two standard formulas in G3:I3 are is,
=IFERROR(INDEX(A$2:A$4, MATCH(0, IF(COUNTIF(G$2:G2, A$2:A$4&"")<COUNT($1:$1), 0, 1), 0)), "")
=IF(LEN(G3), INDEX($B$1:INDEX($1:$1, MATCH(1E+99,$1:$1 )), , COUNTIF(G$3:G3, G3)), "")
=INDEX(A:J,MATCH(G3,A:A,0),MATCH(H3,$1:$1,0))
Fill down as necessary.
While array formulas can negatively impact performance due to their cyclic calculation, your described working environment of 40 rows × 50 columns should not overly impact performance with a calculation lag.
¹ Array formulas need to be finalized with Ctrl+Shift+Enter↵. Once entered into the first cell correctly, they can be filled or copied down or right just like any other formula. Try and reduce full-column references to ranges more closely representing the extents of your actual data. Array formulas chew up calculation cycles logarithmically so it is good practise to narrow the referenced ranges to a minimum. See Guidelines and examples of array formulas for more information.
For anyone who wants to use the PivotTable to do this and is following the below guide:
http://spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/
If you want to do it in Excel 2007 or 2010 then you first need to enable the PivotTable Wizard.
To find the option you need to go to "Excel Options" via the Main Excel Window icon, and see the options selected in the "customize" section, then select "Commands Not in the Ribbon" from the "Choose Commands from:" dropdown and "PivotTable and PivotChart Wizard" needs to be added to the right.. see the image below.
Once that is done there should be a small pivottable wizard icon in the quickbar menu at the top of the Excel window, you can then follow the same process as shown in the link above.
I developed another macro because I needed to refresh the output table quite often (input table was filled by other) and I wanted to have more info in my output table (more copied column and some formulas)
Sub TableConvert()
Dim tbl As ListObject
Dim t
Rows As Long
Dim tCols As Long
Dim userCalculateSetting As XlCalculation
Dim wrksht_in As Worksheet
Dim wrksht_out As Worksheet
'##block calculate and screen refresh
Application.ScreenUpdating = False
userCalculateSetting = Application.Calculation
Application.Calculation = xlCalculationManual
'## get the input and output worksheet
Set wrksht_in = ActiveWorkbook.Worksheets("ressource_entry")'## input
Set wrksht_out = ActiveWorkbook.Worksheets("data")'## output.
'## get the table object from the worksheet
Set tbl = wrksht_in.ListObjects("Table14") '## input
Set tb2 = wrksht_out.ListObjects("Table2") '## output.
'## delete output table data
If Not tb2.DataBodyRange Is Nothing Then
tb2.DataBodyRange.Delete
End If
'## count the row and col of input table
With tbl.DataBodyRange
tRows = .Rows.Count
tCols = .Columns.Count
End With
'## check every case of the input table (only the data part)
For j = 2 To tRows '## parse all row from row 2 (header are not checked)
For i = 5 To tCols '## parse all column from col 5 (first col will be copied in each record)
If IsEmpty(tbl.Range.Cells(j, i).Value) = False Then
'## if there is time enetered create a new row in table2 by using the first colmn of the selected cell row and cell header plus some formula
Set oNewRow = tb2.ListRows.Add(AlwaysInsert:=True)
oNewRow.Range.Cells(1, 1).Value = tbl.Range.Cells(j, 1).Value
oNewRow.Range.Cells(1, 2).Value = tbl.Range.Cells(j, 2).Value
oNewRow.Range.Cells(1, 3).Value = tbl.Range.Cells(j, 3).Value
oNewRow.Range.Cells(1, 4).Value = tbl.Range.Cells(1, i).Value
oNewRow.Range.Cells(1, 5).Value = tbl.Range.Cells(j, i).Value
oNewRow.Range.Cells(1, 6).Formula = "=WEEKNUM([#Date])"
oNewRow.Range.Cells(1, 7).Formula = "=YEAR([#Date])"
oNewRow.Range.Cells(1, 8).Formula = "=MONTH([#Date])"
End If
Next i
Next j
ThisWorkbook.RefreshAll
'##unblock calculate and screen refresh
Application.ScreenUpdating = True
Application.Calculate
Application.Calculation = userCalculateSetting
End Sub
VBA solution may not be acceptable under some situations (e.g. cannot embed macro due to security reasons, etc.). For these situations, and otherwise too in general, I prefer using formulae over macro.
I am trying to describe my solution below.
input data as shown in question (B2:F5)
column_header (C2:F2)
row_header (B3:B5)
data_matrix (C3:F5)
no_of_data_rows (I2) = COUNTA(row_header) + COUNTBLANK(row_header)
no_of_data_columns (I3) = COUNTA(column_header) + COUNTBLANK(column_header)
no_output_rows (I4) = no_of_data_rows*no_of_data_columns
seed area is K2:M2, which is blank but referenced, hence not to be deleted
K3 (drag through say K100, see comments description) = ROW()-ROW($K$2) <= no_output_rows
L3 (drag through say L100, see comments description) = IF(K3,IF(COUNTIF($L$2:L2,L2)
M3 (drag through say M100, see comments description) = IF(K3,IF(M2 < no_of_data_columns,M2+1,1),"-")
N3 (drag through say N100, see comments description) = INDEX(row_header,L3)
O3 (drag through say O100, see comments description) = INDEX(column_header,M3)
P3 (drag through say P100, see comments description) = INDEX(data_matrix,L3,M3)
Comment in K3: Optional: Check if expected no. of output rows has been achieved. Not required, if one only prepares this table limited to no. of output rows.
Comment in L3: Goal: Each RowIndex (1 .. no_of_data_rows) must repeat no_of_data_columns times. This will provide index lookup for row_header values. In this example, each RowIndex (1 .. 3) must repeat 4 times. Algorithm: Check how many times RowIndex has occurred yet. If it less than no_of_data_columns times, continue using that RowIndex, else increment the RowIndex. Optional: Check if expected no. of output rows has been achieved.
Comment in M3: Goal: Each ColumnIndex (1 .. no_of_data_columns) must repeat in a cycle. This will provide index lookup for column_header values. In this example, each ColumnIndex (1 .. 4) must repeat in a cycle. Algorithm: If ColumnIndex exceeds no_of_data_columns, restart the cycle at 1, else increment the ColumnIndex. Optional: Check if expected no. of output rows has been achieved.
Comment in R4: Optional: Use column K for error handling, as shown in column L and column M. Check if looked up value IsBlank to avoid incorrect "0" in the output because of blank input in data_matrix.
updated ReversePivotTable function so i can specify number of header columns and rows
Sub ReversePivotTable()
' Before running this, make sure you have a summary table with column headers.
' The output table will have three columns.
Dim SummaryTable As Range, OutputRange As Range
Dim OutRow As Long
Dim r As Long, c As Long
Dim lngHeaderColumns As Long, lngHeaderRows As Long, lngHeaderLoop As Long
On Error Resume Next
Set SummaryTable = ActiveCell.CurrentRegion
If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
MsgBox "Select a cell within the summary table.", vbCritical
Exit Sub
End If
SummaryTable.Select
Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
lngHeaderColumns = Application.InputBox(prompt:="Header Columns")
lngHeaderRows = Application.InputBox(prompt:="Header Rows")
' Convert the range
OutRow = 2
Application.ScreenUpdating = False
'OutputRange.Range("A1:D3") = Array("Column1", "Column2", "Column3", "Column4")
For r = lngHeaderRows + 1 To SummaryTable.Rows.Count
For c = lngHeaderColumns + 1 To SummaryTable.Columns.Count
' loop through all header columns and add to output
For lngHeaderLoop = 1 To lngHeaderColumns
OutputRange.Cells(OutRow, lngHeaderLoop) = SummaryTable.Cells(r, lngHeaderLoop)
Next lngHeaderLoop
' loop through all header rows and add to output
For lngHeaderLoop = 1 To lngHeaderRows
OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderLoop) = SummaryTable.Cells(lngHeaderLoop, c)
Next lngHeaderLoop
OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderRows + 1) = SummaryTable.Cells(r, c)
OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderRows + 1).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
OutRow = OutRow + 1
Next c
Next r
End Sub
Code with the claim for some universality
The book should have two sheets:
Sour = Source data
Dest = the "extended" table will drop here
Option Explicit
Private ws_Sour As Worksheet, ws_Dest As Worksheet
Private arr_2d_Sour() As Variant, arr_2d_Dest() As Variant
' https://stackoverflow.com/questions/52594461/find-next-available-value-in-excel-cell-based-on-criteria
Public Sub PullOut(Optional ByVal msg As Variant)
ws_Dest_Acr _
arr_2d_ws( _
arr_2d_Dest_Fill( _
arr_2d_Sour_Load( _
arr_2d_Dest_Create( _
CountA_rng( _
rng_2d_For_CountA( _
Init))))))
End Sub
Private Function ws_Dest_Acr(Optional ByVal msg As Variant) As Variant
ws_Dest.Activate
End Function
Public Function arr_2d_ws(Optional ByVal msg As Variant) As Variant
If IsArray(arr_2d_Dest) Then _
ws_Dest.Cells(1, 1).Resize(UBound(arr_2d_Dest), UBound(arr_2d_Dest, 2)) = arr_2d_Dest
End Function
Private Function arr_2d_Dest_Fill(Optional ByVal msg As Variant) As Variant
Dim y_Sour As Long, y_Dest As Long, x As Long
y_Dest = 1
For y_Sour = LBound(arr_2d_Sour) To UBound(arr_2d_Sour)
' without the first column
For x = LBound(arr_2d_Sour, 2) + 1 To UBound(arr_2d_Sour, 2)
If arr_2d_Sour(y_Sour, x) <> Empty Then
arr_2d_Dest(y_Dest, 1) = arr_2d_Sour(y_Sour, 1) 'iD
arr_2d_Dest(y_Dest, 2) = arr_2d_Sour(y_Sour, x) 'DTLx
y_Dest = y_Dest + 1
End If
Next
Next
End Function
Private Function arr_2d_Sour_Load(Optional ByVal msg As Variant) As Variant
arr_2d_Sour = ReDuce_rng(ws_Sour.UsedRange, 1, 0).Offset(1, 0).Value
End Function
Private Function arr_2d_Dest_Create(ByVal iRows As Long)
Dim arr_2d() As Variant
ReDim arr_2d(1 To iRows, 1 To 2)
arr_2d_Dest = arr_2d
arr_2d_Dest_Create = arr_2d
End Function
Public Function CountA_rng(ByVal rng As Range) As Double
CountA_rng = Application.WorksheetFunction.CountA(rng)
End Function
Private Function rng_2d_For_CountA(Optional ByVal msg As Variant) As Range
' without the first line and without the left column
Set rng_2d_For_CountA = _
ReDuce_rng(ws_Sour.UsedRange, 1, 1).Offset(1, 1)
End Function
Public Function ReDuce_rng(rng As Range, ByVal iRow As Long, ByVal iCol As Long) _
As Range
With rng
Set ReDuce_rng = .Resize(.Rows.Count - iRow, .Columns.Count - iCol)
End With
End Function
Private Function Init()
With ThisWorkbook
Set ws_Sour = .Worksheets("Sour")
Set ws_Dest = .Worksheets("Dest")
End With
End Function
'https://youtu.be/oTp4aSWPKO0