Copying Values and Color Index in an Array - vba

I have a macro that allows me to open multiple files based on their names and copy sheets based on a criteria (if there's a value in column "X" then copy the row but only some colums "F,G,P,Q,W,X,Y) to another unique workbook.
the problem is in column F i have a color and i want to retrieve the color index but the macro leaves it blank
[1] Get data from A1:Z{n}
n = ws.Range("A" & Rows.Count).End(xlUp).Row ' find last row number n
v = ws.Range("A10:Y" & n).Value2 ' get data cols A:Y and omit header row
[2] build array containing found rows
a = buildAr2(v, 24) ' search in column X = 24
' [3a] Row Filter based on criteria
v = Application.Transpose(Application.Index(v, _
a, _
Application.Evaluate("row(1:" & 26 & ")"))) ' all columns from A to Z
[3b] Column Filter F,G,P,Q,W,X,Y
v = Application.Transpose(Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(a) - LBound(a) + 1 & ")"), _
Array(6, 7, 16, 17, 23, 24, 25)))) ' only cols F,G,P,Q,W,X,Y
Function buildAr2(v, ByVal vColumn&, Optional criteria) As Variant
' Purpose: Helper function to check in Column X
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, j&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
If Len(Trim(v(i, vColumn))) > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr2 = ar
End Function

How to copy filtered array values together with color format (column F)
You got the solution to filter a data field Array v by row AND column using the Application.Index property and write these data to a target sheet - c.f. Multi criteria selection with VBA
Your issue was to find a way to write not only data, but also the source color formatting of column F to the target cells, as an array per se contains values and no color info.
Write the filtered information to a defined STARTROW (e.g. 10), then you can use the item numbers of array a adding a headline offset headerIncrement) to reconstruct the source row numbers by a simple loop in order to get/write the color formats, too:
Code addition
' [4a] Copy results array to target sheet, e.g. start row at A10
Const STARTROW& = 10
ws2.Cells(STARTROW, 1).Offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
' **************************************************************************
' [4b] Copy color formats using available item number information in array a
' **************************************************************************
Dim sourceColumn&: sourceColumn = 6 ' <<~~ source column F = 6
Dim targetColumn&: targetColumn = 1 ' <<~~ becomes first target column
Dim headerIncrement&: headerIncrement = STARTROW - 1
For i = 0 To UBound(a)
ws2.Cells(i + headerIncrement, targetColumn).Offset(1, 26).Interior.Color = _
ws.Cells(a(i) + headerIncrement, sourceColumn).Interior.Color
Next i
Side Note Don't forget to set Option Explicit to force declaration of variables and to declare the variable howMany (used in both procedures) in the declaration head of your code module.

I have no idea where the problem is, but you asked:
the problem is in column F i have a color and i want to retrieve the
color index but the macro leaves it blank
Here's how you retrieve the colorindex from Cell A1:
col = Range("A1").Interior.ColorIndex
I would suggest you try retrieving it and if you run into a problem: open a question with your example, as Pᴇʜ suggested.

In addition to the comments above by #Pᴇʜ, the fact that you are mainly dealing with v, a variant array of strings, is going to be a limiting factor. You are going to have to deal with a Range if you want the .Interior.ColorIndex property of the cell (Range).
Also, if you want to be precise about the color, use color instead of ColorIndex.
ColorIndex will return the closest indexed color.

Related

VBA - to compare 2 tables from 2 sheets, and get result in another sheets creating comparison table

It is above my possibilities.
I know how to create Vba code with Vlookup or Hlookup for single comparision. However whatIi am trying is beyond my knowledge.
I need to compare 2 tables. 1st is requirements where 2nd is DB extract.
Both tables contains same "Action" column and other columns with Employer role as a header. Values from Action column for both tables are the same however in different order ( Those values need to act as primary key).
Columns with Employer role as a header - same header value for both tables - however columns in different order.
Amount of columns with Employer role as a header is not constants and it gets change every time I get this files. Those columns in extract are in different order than in requirements.
Amount of values from "Action" columns ( primary key) also not constants and change every time I receive files. So I cannot set specific range.
Example of Requirements table
Example of Extract table
Example of what is expected
New target worksheet need to be created where Comparison table will be created.
VBA to create Comparison table in newly created worksheet.
This table should have "Action" column + all columns with Employers role as header form requirements + all columns with Employers role as header form extract set in same order like columns in requirements + comparison table which compare values between Employers roles from Requirements and Extract and show values YES or NO
Try the next code, please. It will return in a newly created sheet (after the last existing). The new file is named "New Sheet". If it exists, it is cleared and reused:
Sub testMatchTables()
Dim sh As Worksheet, sh1 As Worksheet, shNew As Worksheet
Dim tbl1 As ListObject, tbl2 As ListObject, rightH As Long
Dim arrR, arrE, arrH1, arrH2, arrFin, i As Long, j As Long, k As Long
Dim first As Long, sec As Long, refFirst As Long, refSec As Long
Set sh = Set sh = Worksheets("Requirements")'use here the sheet keeping the first table
Set sh1 = Worksheets("Extract Table") 'use here your appropriate sheet
Set tbl1 = sh.ListObjects(1) 'use here your first table name (instead of 1)
Set tbl2 = sh1.ListObjects(1) 'use here your second table name (instead of 1)
arrR = tbl1.Range.value 'put the table range in an array
arrE = tbl2.Range.value 'put the table range in an array
'working with arrays will condiderably increase the processing speed
ReDim arrFin(1 To UBound(arrR), 1 To UBound(arrR, 2) * 3 + 2) 'redim the array to keep the processing result
'UBound is a property telling the number of array elements
arrH1 = Application.Index(arrR, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
arrH2 = Application.Index(arrE, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
'build the column headers:
For i = 1 To UBound(arrFin, 2)
If i <= UBound(arrH1) Then 'firstly the headers of the first table are filled in the final array
arrFin(1, i) = arrH1(i)
ElseIf refSec = 0 Then 'refSec is the column where a blanck column will exist
first = first + 1 'the code incrementes this variable to allow making empty only for the following row
If first = 1 Then
arrFin(1, i) = Empty: refFirst = i 'make the empty column between the two tables data and create a reference
'to be decreated from the already incremented i variable
Else
arrFin(1, i) = arrH1(i - refFirst) 'place each header column values
If i - refFirst = UBound(arrH1) Then refSec = i + 1 'when the code reaches the end of the first array
'it creates a reference for referencing the second time
End If
Else
sec = sec + 1 'the same philosophy as above, to create the second empty column
If sec = 1 Then
arrFin(1, i) = Empty 'create the empty column (for each processed row)
Else
arrFin(1, i) = arrH1(i - refSec) 'fill the header columns
End If
End If
Next
Dim C As Long, r As Long, eT As Long, T As Long
eT = UBound(arrR) 'mark the ending of the first array (where to be the first empty column)
T = UBound(arrR, 2) * 2 + 2 'mark the begining of the third final array part
'after the second empty column
For i = 2 To UBound(arrR) 'iterating between the first array rows
For j = 2 To UBound(arrE) 'iterating the second array rows
If arrR(i, 1) = arrE(j, 1) Then 'if the both arrays first column matches
arrFin(i, 1) = arrR(i, 1): arrFin(i, T + 1) = arrR(i, 1) 'put the Action values in the first area columns
arrFin(i, eT) = arrR(i, 1) 'put the Action values in the last area column
For C = 2 To UBound(arrR, 2) 'iterate between the array columns
rightH = Application.match(arrR(1, C), arrH2, 0) 'find the match of the first array header in the second one
arrFin(i, C) = arrR(i, C): arrFin(i, C + eT - 1) = arrE(j, rightH) 'place the matching header in the final array
If arrR(i, C) = arrE(j, rightH) Then
arrFin(i, T + C) = "TRUE" 'place 'TRUE' in case of matching
Else
arrFin(i, T + C) = "FALSE" 'place 'FALSE' in case of NOT matching
End If
Next C
End If
Next j
Next i
On Error Resume Next 'necessary to return an error if worksheet "New Sheet" does not exist
Set shNew = Worksheets("New Sheet")
If err.Number = 9 Then 'if it raises error number 9, this means that the sheet does not exist
err.Clear: On Error GoTo 0 'clear the error and make the code to return other errors, if any
Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.count)) 'set shNew as new inserted sheet
shNew.name = "New Sheet" 'name the newly inserted sheet
Else
shNew.cells.Clear: On Error GoTo 0 ' in case of sheet exists, it is clear and the code is made to return errors
End If
'set the range where the final array to drop its values:
With shNew.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.value = arrFin 'drop the array content
.EntireColumn.AutoFit 'AutoFit the involved columns
End With
End Sub
Please, test it and send some feedback.
Edited:
I commented the code as detailed I could. If still something unclear, please do not hesitate to ask for clarifications.

VBA - check for duplicates while filling cells through a loop

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.

Custom sort routine for unique string A being place after another string B, C, D, etc if string A is found within them

Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.

return single values for multiple records

Is there a way to merge multiple records then display only the highest value for each column? Example: A2:A25=names, B2=Grade1, C2=Grade2...etc.
First I removed duplicates in case there are exact duplicates. Then I sort on Name.
Can something be added to this code, based on column A-names, to display each name once with the highest value from each column?
=IF(B2="","Empty",IF(B2="High","High",IF(B2="Med","Med",IF(B2="Low","Low",""))))
Data Example
A1:name B1:Grade1 C1:Grade2...etc
A2:Joe B2:High C3:Low
A3:Joe B3:Med C3:High
A4:Dan B4:Low C4:Med
A5:Dan B5:Low C5:Low
__Results: Joe Grade1=high Grade2=high, Dan: Grade1=Low Grade2=Med
Record an Excel macro. Select first column. Click advanced filter.Choose copy to location and select a new column say X. Enable unique filter. Now click Ok. Now look at vba source to get the code to get unique elements in a column. Now assign Low as 0, Med as 1, High as 2 . loop through the rows and find the maximum grade1 , maximum grade2 etc corresponding to each element in column X and populate columns Y,Z etc. As and when you find a new maximum replace the existing. Now you will have the required data in columns X,Y,Z. Loop through them again and display in the format what you needed.
Decided to try VBA code for this one. It's a bit bruitish, but gets the job done.
Took a shortcut and made columns b and c numbers rather than strings. You could do a lookup function on the spreadsheet to make that conversion, or add an extra check in the code.
Sub find_high_values()
' subroutine to find max values of columns b and c against names
' assumes for simplicity that there are no more than 10 rows
' assumes values being checked to be numbers, if they are strings, additional loops would need to be done
Dim sName(10) As String, lBval(10) As Long, lCval(10) As Long 'arrays for original list
Dim iCountN As Integer, iUnique As Integer, iUniqueCount As Integer 'counters
Dim bUnique As Boolean
Dim rStart As Range, rOutput As Range 'ranges on worksheet
Dim lBmax(10) As Long, lCmax(10) As Long, sUniqueName(10) As String 'output arrays
Set rStart = ActiveSheet.Range("d6") 'Cell immediately above the first name in list
Set rOutput = ActiveSheet.Range("j6") 'cell reference for max value list
iUniqueCount = 1
For iCountN = 1 To 10 'set max counters to a min value
lBmax(iCountN) = 0
lCmax(iCountN) = 0
Next
For iCountN = 1 To 10 'step through each original row
sName(iCountN) = rStart.Offset(iCountN, 0).Value
lBval(iCountN) = rStart.Offset(iCountN, 1).Value
lCval(iCountN) = rStart.Offset(iCountN, 2).Value
bUnique = True 'Starter value, assume the name to be unique, changes to false if already in list
For iUnique = 1 To iCountN 'loop to check if it is a new name
If sUniqueName(iUnique) = sName(iCountN) Then bUnique = False
Next
If bUnique Then 'if new name, add to list of names
sUniqueName(iUniqueCount) = sName(iCountN)
iUniqueCount = iUniqueCount + 1
End If
Next
iUniqueCount = iUniqueCount - 1 'make the count back to total number of names found
For iUnique = 1 To iUniqueCount 'loop through names
For iCountN = 1 To 10 'loop through all values
If sName(iCountN) = sUniqueName(iUnique) Then
If lBval(iCountN) > lBmax(iUnique) Then lBmax(iUnique) = lBval(iCountN)
If lCval(iCountN) > lCmax(iUnique) Then lCmax(iUnique) = lCval(iCountN)
End If
Next
Next
'output section
rStart.Resize(1, 3).Select
Selection.Copy
rOutput.PasteSpecial xlPasteValues
For iUnique = 1 To iUniqueCount
rOutput.Offset(iUnique, 0).Value = sUniqueName(iUnique)
rOutput.Offset(iUnique, 1).Value = lBmax(iUnique)
rOutput.Offset(iUnique, 2).Value = lCmax(iUnique)
Next
End Sub

How to "flatten" or "collapse" a 2D Excel table into 1D?

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