So what I want is a button that when pressed will automatically name the right hand column cells the left hand column values, my code at the moment looks something like this,
Private Sub CommandButton1_Click()
Range("F3").Name = Range("E3")
Range("F4").Name = Range("E4")
Range("F5").Name = Range("E5")
Range("F6").Name = Range("E6")
End Sub
I'm new to using VBA and have looked around a little but couldn't find what I wanted to achieve. Just want a simple solution which can automatically do what my code already does without having to be specific about cell rows.
I imagine that there will be either a while or for loop to repeat over many rows and an if statement for the code not running if a cell is empty.
Basically I want the command to run something like below but don't quite know how to write it in excel VBA myself.
for j=3:100
if F(j) = non empty
F(j).name = E(j)
else end
next j
end
Image below shows the end result :
From your sample image this looks like it should work.
Option Explicit
Sub name_eff()
Dim rw As Long
With Worksheets("Sheet6")
For rw = 2 To Application.Min(.Cells(.Rows.Count, "E").End(xlUp).Row, _
.Cells(.Rows.Count, "F").End(xlUp).Row)
If Application.CountA(.Cells(rw, "E").Resize(1, 2)) = 2 Then _
.Cells(rw, "F").Name = .Cells(rw, "E").Text
Next rw
End With
End Sub
I have a large data set which I need to manipulate and create individual worksheets. Within column B all cells which are coloured Green I would like to make a new worksheet for. Please see screen shot.
For example I would like to create worksheets titled "Shopping" & "Retail". Once the worksheet is created, I would then like to copy all the data between the "worksheet title" (Green Cells) from columns ("B:C") & ("AI:BH") Please see screen shot below for expected output;
The code I have so far is below as you can see it is not complete as I do not know how I would go about extracting data between the "Green Cells".
Sub wrksheetadd()
Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select
LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))
For i = r.Rows.Count To 1 Step -1
With r.Cells(i, 1)
If .DisplayFormat.Interior.ColorIndex = 35 Then
MsgBox i
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
Worksheets("RING Phased").Select
End If
End With
Next i
End Sub
Any help around this would be much appreciated.
Sorry for taking a while to get back to this, I've been somewhat busy the last few days, so I haven't had much time to be on StackOverflow.
Anyway, the way I'd go about this would be to store all the found values in an array, and then loop through that array in order to find the distance between them.
The following code works for me, using some very simplified data, but I think the principle is sound:
Option Explicit
Option Base 0
Sub wrksheetadd()
Dim r As Range, c As Range
Dim i As Long: i = 0
Dim cells_with_color() As Range: ReDim cells_with_color(1)
With Worksheets("RING Phased")
' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
' This also saves us from having to test if the array is empty later.
Set cells_with_color(i) = .Range("B12")
i = i + 1
Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))
' Put all the cells with color in the defined range into the array
For Each c In r
If c.DisplayFormat.Interior.ColorIndex = 35 Then
If i > UBound(cells_with_color) Then
ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
End If
Set cells_with_color(i) = c
i = i + 1
End If
Next
' Loop through the array, and copy from the previous range value to the current one into a new worksheet
' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
' (Hmm, reusing variables may be bad practice >_>)
i = 1
While i <= UBound(cells_with_color)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
' If you want to refine it a bit, just change whatever you set r to in the previous statement.
r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
i = i + 1
Wend
End With
End Sub
It probably lacks some error-checking which ought to be in there, but I'll leave that as an exercise to you to figure out. I believe it is functional. Good luck!
I have the below mentioned code, I am trying to load filtered cells only into the listbox but I don't know why the below mentioned code is not functional.
Legend:
PatternSearchButton is a button
PatternTextBox is a textbox by which the user enters a value Which the Sheet will filter.
WsLookup is a function which selects the sheet (completely functional)
Private Sub PatternSearchButton_Click()
Dim PatternInput As String, PatternCounter As Double, WsSelector As Worksheet
PatternInput = PatternTextBox.Value
Set WsSelector = WsLookup(GSMListType.Value)
WsSelector.Range("F:F").AutoFilter Field:=1, Criteria1:=PatternInput
PatternCounter = Application.WorksheetFunction.Subtotal(4, WsSelector.Range("F:F"))
With AvailableNumberList
.Clear
For k = 2 To PatternCounter + 1
.AddItem WsSelector.Range("A" & k).SpecialCells(xlCellTypeVisible).Value
Next k
End With
End Sub
You're are using PatternCounter as the upper limit in your For .. Next but this is being set using the MAX (e.g. 4) subfunction of SUBTOTAL. This might work on sequential numbers in an unfiltered list but it is unlikely to be accurate in a filtered list. Using the COUNT (2/102) or COUNTA (3/103) subfunction might be more appropriate.
You were using SUBTOTAL(4, ...) so I would assume that you are dealing with numbers. Use a straight count on numbers on visible cells in column F and modify the remainder of the code to resemble this.
PatternCounter = Application.WorksheetFunction.Subtotal(2, WsSelector.Range("F:F"))
With WsSelector.cells(1,1).currentregion.offset(1,0).SpecialCells(xlCellTypeVisible)
AvailableNumberList.Clear
For k = 1 To PatternCounter
AvailableNumberList.AddItem .cells(k, 1).Value
Next k
End With
The problem might stem from the fact that you add to the list box the value of a special cell that might not exist if the cell is hidden.
Try for the body of the For loop:
' ... previous code '
If Not WsSelector.Rows(k).EntireRow.Hidden Then
.AddItem WsSelector.Cells(k, 1).Value
End If
' rest of the code ... '
Also, make sure that AvailableNumberList points to the correct object in your code.
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