I am trying to take a range of values in a number of sets, and write a VBA code to fill in grouped cells with the minimum and maximum values in the range.
Example Table
Group
Value
A
10
A
3
A
5
B
1
B
3
The expected outputs should be a table or cells that say
A Range : 3-10
B Range : 1-3
Obviously, I could do this with a min and max formula, for each set, however, I'm wondering if there's a way to do this in VBA as the number of sets is in excess of a few hundred
You can certainly do this with VBA and/or Power Query, although, as others have written and you are aware, formulas are a viable option.
Source Data
for VBA:
Read the source data into a VBA array for fastest processing
create a class module to hold the minumum and maximum values
Group the ranges using a Dictionary, which in turn holds the class object
Create a results array and write it to the worksheet.
Class Module
'ReNAME this "cGroup"
Option Explicit
Private pMin As Long
Private pMax As Long
Public Property Get Min() As Long
Min = pMin
End Property
Public Property Let Min(Value As Long)
pMin = Value
End Property
Public Property Get Max() As Long
Max = pMax
End Property
Public Property Let Max(Value As Long)
pMax = Value
End Property
Regular Module
'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub generateRanges()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant, v As Variant
Dim I As Long
Dim D As Dictionary, sKey As String
Dim cG As cGroup
'set the source and results worksheets
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set wsRes = ThisWorkbook.Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'read source data into vba array
With wsSrc
vSrc = Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With
'set dictionary to collect the data
Set D = New Dictionary
D.CompareMode = TextCompare
'iterate through the data
'pull out the min and max of the range
For I = 2 To UBound(vSrc, 1)
sKey = vSrc(I, 1)
Set cG = New cGroup
If Not D.Exists(sKey) Then
cG.Max = vSrc(I, 2)
cG.Min = vSrc(I, 2)
D.Add Key:=sKey, Item:=cG
Else
With D(sKey)
.Max = IIf(.Max > vSrc(I, 2), .Max, vSrc(I, 2))
.Min = IIf(.Min < vSrc(I, 2), .Min, vSrc(I, 2))
End With
End If
Next I
'create the results array
ReDim vRes(0 To D.Count, 1 To 2)
'Column Headers
vRes(0, 1) = "Range"
vRes(0, 2) = "Value"
I = 0
For Each v In D.Keys
I = I + 1
vRes(I, 1) = v & " Range"
vRes(I, 2) = D(v).Min & "-" & D(v).Max
Next v
'write results to results worksheet
With rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
.EntireColumn.Clear
.NumberFormat = "#"
.Value = vRes
.Style = "Output" 'not internationally aware
.EntireColumn.AutoFit
End With
End Sub
Or, using Power Query (which I prefer because its shorter and easier to program) available in Windows Excel 2010+ and Office 365:
Select some cell in your Data Table
Data => Get&Transform => from Table/Range
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
//Read in the table
// Change Table name in next line to actual table name
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
//type the data
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Group", type text}, {"Value", Int64.Type}}),
//Group by "Group"
// then generate the min-max string
#"Grouped Rows" = Table.Group(#"Changed Type", {"Group"}, {{"Value",
each Text.From(List.Min([Value])) & "-" & Text.From(List.Max([Value])), Text.Type }
}),
//Add the word " Range" to the Group
addRange = Table.TransformColumns(#"Grouped Rows",{"Group", each _ & " Range", Text.Type})
in
addRange
Either produces the same results from your data:
Indeed, VBA isn't the best solution in this case because a single formula can extract all the data you want. There is no need to make a different formula for each group.
=MINIFS(INDEX(Data,,2),INDEX(Data,,1),H2) & " - " & MAXIFS(INDEX(Data,,2),INDEX(Data,,1),H2)
The formula for the dynamic named range is =OFFSET(Sheet1!$A$2,0,0,COUNTA(Sheet1!$A:$A)-1,2)
If you want to go with formula then could try below formula with Excel365.
D2=UNIQUE(A2:A6)
E2=MINIFS(B2:B6,A2:A6,D2#)&"-"&MAXIFS(B2:B6,A2:A6,D2#)
Related
I am new to VBA and am trying to copy the column from Row 2 onwards where the column header (in Row 1) contains a certain word- "Unique ID".
Currently what I have is:
Dim lastRow As Long
lastRow = ActiveWorkbook.Worksheets("Sheets1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheets1").Range("D2:D" & lastRow).Copy
But the "Unique ID" is not always in Column D
You can try following code, it loops through first row looking for a specified header:
Sub CopyColumnWithHeader()
Dim i As Long
Dim lastRow As Long
For i = 1 To Columns.Count
If Cells(1, i) = "Unique ID" Then
lastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Range("A2")
Exit For
End If
Next
End Sub
When you want to match info in VBA you should use a dictionary. Additionally, when manipulating data in VBA you should use arrays. Although it will require some learning, below code will do what you want with minor changes. Happy learning and don't hesitate to ask questions if you get stuck:
Option Explicit
'always add this to your code
'it will help you to identify non declared (dim) variables
'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
Sub DictMatch()
'Example of match using dictionary late binding
'Sourcesheet = sheet1
'Targetsheet = sheet2
'colA of sh1 is compared with colA of sh2
'if we find a match, we copy colB of sh1 to the end of sh2
'''''''''''''''''
'Set some vars and get data from sheets in arrays
'''''''''''''''''
'as the default is variant I don't need to add "as variant"
Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
'when creating a dictionary we can use early and late binding
'early binding has the advantage to give you "intellisense"
'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
dict.CompareMode = 1 'textcompare
arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
'''''''''''''''''
'Loop trough source, calculate and save to target array
'''''''''''''''''
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediate array (arr3) to store the results
'We use a "dictionary" to match values in vba because this allows to easily check the existence of a value
'Together with arrays and collections these are probably the most important features to learn in vba!
For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
End If
Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
'1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
'1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
ReDim arr3(1 To UBound(arr2), 1 To 1)
For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
End If
Next j 'go to the next row
'''''''''''''''''
'Write to sheet only at the end, you could add formatting here
'''''''''''''''''
With Sheet2 'sheet on which I want to write the matching result
'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
'.Cells(1, UBound(arr2, 2) + 1) = The startcel => row = 1, col = nr of existing cols + 1
'.Cells(UBound(arr2), UBound(arr2, 2) + 1)) = The lastcel => row = number of existing rows, col = nr of existing cols + 1
.Range(.Cells(1, UBound(arr2, 2) + 1), .Cells(UBound(arr2), UBound(arr2, 2) + 1)).Value2 = arr3 'write target array to sheet
End With
End Sub
I'm novice in VBA. I'm trying to transpose my data:
I would like to have this results:
I tried all day the methodes like: Resize(UBound(Table2, 1), UBound(Table2, 2)) = Table2, Application.transpose(Tbl1) but I don't have the diserid result. Could you help me please? Thank you very much!
A Power Query Solution (CVR)
Added corrections; credits to Ron Rosenfeld.
Click into your table.
Select Data > From Table/Range: The Power Query Editor opens containing your data.
The first columns is selected. If not, click the header of your first column (Date) to select it.
Select Transform > Pivot Column: The Pivot Column window opens.
In the Values Column combo box the second column (Values) is already selected. If not, select it.
Click Advanced Options where Sum is already selected which will sum multiple entries for the same ID/Date columns. If not, select it.
Press OK. The data is transformed.
Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.
Short Version
Click into your table.
Select Data > From Table/Range: The Power Query Editor opens containing your data.
Select Transform > Pivot Column: The Pivot Column window opens.
Press OK. The data is transformed.
Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.
With Office365 you can use below formulas (as per my screenshot).
F2=UNIQUE(C1:C11)
G1=TRANSPOSE(SORT(UNIQUE(A1:A10)))
G2=FILTER($B$1:$B$11,($C$1:$C$11=$F2)*($A$1:$A$11=G$1),"")
After putting FILTER() formula to G2 cell drag across right and down as needed.
You can also use XLOOKUP() instead of FILTER() formula to G2 like-
=XLOOKUP(1,($A$1:$A$11=G$1)*($C$1:$C$11=$F2),$B$1:$B$11,"")
Pivot CVR
CVR: Column Labels, Values, Row Labels.
It is assumed that the initial data, the Source Range, contains a row of headers, whose third cell value will be copied to the first cell of the resulting data, the Destination Range.
Adjust the values in the constants section.
Copy the complete code to a standard module, e.g. Module1.
Only run the first procedure, pivotDataCVR, the other two are being called by it, when necessary.
A similar solution, which I based this solution on, although RCV, can be found here.
The Code
Option Explicit
Sub pivotDataCVR()
' Define constants.
Const srcName As String = "Sheet1"
Const srcFirst As String = "A1"
Const dstName As String = "Sheet2"
Const dstFirst As String = "A1"
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Source First Cell Range.
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirst)
' Define Source Range.
Dim rng As Range
With cel.CurrentRegion
Set rng = cel.Resize(.Rows.Count + .Row - cel.Row, _
.Columns.Count + .Column - cel.Column)
End With
' Get unique values.
Dim dts As Variant
dts = getUniqueColumn1D(rng.Columns(1).Resize(rng.Rows.Count - 1).Offset(1))
sort1D dts
Dim idx As Variant
idx = getUniqueColumn1D(rng.Columns(3).Resize(rng.Rows.Count - 1).Offset(1))
sort1D idx
' Write values from Source Range to Source Array.
Dim Source As Variant
Source = rng.Value
' Define Destination Array.
Dim Dest As Variant
ReDim Dest(1 To UBound(idx) - LBound(idx) + 2, _
1 To UBound(dts) - LBound(dts) + 2)
' Write values from arrays to Destination Array.
Dest(1, 1) = Source(1, 3)
Dim n As Long
Dim i As Long
i = 1
For n = LBound(idx) To UBound(idx)
i = i + 1
Dest(i, 1) = idx(n)
Next n
Dim j As Long
j = 1
For n = LBound(dts) To UBound(dts)
j = j + 1
Dest(1, j) = dts(n)
Next n
For n = 2 To UBound(Source, 1)
i = Application.Match(Source(n, 3), idx, 0) + 1
j = Application.Match(Source(n, 1), dts, 0) + 1
Dest(i, j) = Source(n, 2)
Next n
' Define Destination First Cell Range.
Set cel = wb.Worksheets(dstName).Range(dstFirst)
' Define Destination Range.
Set rng = cel.Resize(UBound(Dest, 1), UBound(Dest, 2))
' Write from Destination Array to Destination Range.
rng.Value = Dest
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
' Returns the unique values from a column range in a 1D array.
Function getUniqueColumn1D(ColumnRange As Range, _
Optional ByVal Sorted As Boolean = False) _
As Variant
Dim Data As Variant
Data = ColumnRange.Columns(1).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data, 1)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
.Item(Key) = Empty
End If
Next i
If .Count > 0 Then
getUniqueColumn1D = .Keys
End If
End With
End Function
' Sorts a 1D array only if it contains values of the same data type.
Sub sort1D(ByRef OneD As Variant, _
Optional ByVal Descending As Boolean = False)
With CreateObject("System.Collections.ArrayList")
Dim i As Long
For i = LBound(OneD) To UBound(OneD)
.Add OneD(i)
Next i
.Sort
If Descending Then
.Reverse
End If
OneD = .ToArray
End With
End Sub
I have an employer list indicating the reinforcement shifts per dd/mm/yyyy in an Excel 2003 workbook.
With the next macro I get in the same document, all the GP per person multiplied by 4.83 indicating the result in a new column.
Option Explicit
Sub Resumen()
'------------------
'by Cacho Rodríguez
'------------------
Dim C As Range, Mat, Q&, i&, R&
On Error Resume Next
Set C = Application.InputBox("Selecciona la celda superior izquierda (CODIGO NÓMINA)" & vbLf & _
"de tu rango de datos." & vbLf & vbLf & "(por ejemplo: Full1!$A$1)", Type:=8)
If C Is Nothing Then Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
With C.Worksheet
Mat = .Range(C, .Cells(.Rows.Count, 1 + C.Column).End(xlUp).Offset(, 1))
End With
Q = UBound(Mat)
R = 1
Mat(R, 1) = Mat(1, 1)
Mat(R, 2) = Mat(1, 2)
Mat(R, 3) = "GP"
For i = 2 To Q
Select Case True
Case Mat(i, 1) = ""
Mat(R, 3) = 1 + Mat(R, 3)
Case IsNumeric(Mat(i, 1))
R = 1 + R
Mat(R, 1) = 0 + Mat(i, 1)
Mat(R, 2) = Mat(i, 2)
Mat(R, 3) = 0
End Select
Next
C.Worksheet.[g1].CurrentRegion.Delete xlUp
With C.Worksheet.[g1].Resize(R, 3)
Application.Goto .Cells(1).Offset(, -3), True
.Value = Mat
.Columns(4) = "=4.83 * " & .Cells(1, 3).Address(0, 0)
.Cells(1, 4) = "Total"
.Resize(, 4).Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
I need too all GF in a new column and in the "Total column", the result of GP+GF*4.83.
But I need the GP and GF separate per month, and the total per month per employer.
For example something like the next picture:
It took a bit for me to figure out what you want to do. If I understand properly: your 3rd image is a Summary of the data in the 1st image, and you want it to also include the data from your 2nd image.
If this is going to be an ongoing report then your first step should be organizing the data better, which will then make this and anything else you ever want to do with this data in Excel a lot easier for you and others.
If your data were organized like this:
...then with just a few clicks, you can have you data displayed like this automatically:
...and any time you add or change data, it take 1 click to update this table. It only took a few minutes to create this pivot table (now that the data is organized properly).
One in place, the pivot table can be changed with only a few clicks to instantly report on the data in different ways.
Same goes for Charts (which took a couple minutes to create, and will automatically update when the data changes) and various other Excel features:
You're doing things the "hard way" by using VBA to create your reports -- but it's very common from users who aren't aware of the functionality already built-in to Excel. But as I said, the first step in organizing your data in a more logical fashion (basically, "one record per row" with no sub-headings in between rows, like the Nom on your sample data.)
If you'd like to play around with the workbook I used for the examples, you can download it from Jumpshare here. (It probably won't display properly on the JumpShare website (because of the charts, etc) but click the Download button to download the [macro-free] .XLSX file.
More Information:
Microsoft : Guidelines for organizing and formatting data on a worksheet
Hubspot : How to Create a Pivot Table in Excel: A Step-by-Step Tutorial (With Video)
Office.com : Create a PivotTable to analyze worksheet data
GCFLearnFree: Introduction to Pivot Tables (with practice workbook)
Here is a macro that will reorder the data you have into a more useable format as recommended by #ashleedawg. The macro makes use of two Classes to help with orgainizing, and the self-documenting feature will be useful for future modifications.
After you have reordered your data, you can then apply pivot tables to generate whatever type of report you wish. For the 4,83 multiplier, you can add a Calculated Field to the Pivot Table.
And, you can even record a macro to automate the generation of the Pivot Table, if you wish.
For information on Classes, take a look at Chip Pearson's Introduction to Classes
As noted in the comments in the various modules:
Be sure to set a Reference to Microsoft Scripting Runtime
Be sure to rename the Class Modules
Be sure your worksheets for the original and results data are named appropriately in the reOrder macro
Class Module
Option Explicit
'RENAME cShiftData
Private pCodigo As Long
Private pNom As String
Private pDt As Date
Private pDNI As String
Private pGP As Double
Private pGF As Double
Private pSD As cShiftData
Private pDts As Dictionary
Public Property Get Codigo() As Long
Codigo = pCodigo
End Property
Public Property Let Codigo(Value As Long)
pCodigo = Value
End Property
Public Property Get Nom() As String
Nom = pNom
End Property
Public Property Let Nom(Value As String)
pNom = Value
End Property
Public Property Get Dt() As Date
Dt = pDt
End Property
Public Property Let Dt(Value As Date)
pDt = Value
End Property
Public Property Get DNI() As String
DNI = pDNI
End Property
Public Property Let DNI(Value As String)
pDNI = Value
End Property
Public Property Get GP() As Double
GP = pGP
End Property
Public Property Let GP(Value As Double)
pGP = Value
End Property
Public Property Get GF() As Double
GF = pGF
End Property
Public Property Let GF(Value As Double)
pGF = Value
End Property
Public Property Get Dts() As Dictionary
Set Dts = pDts
End Property
Public Function addDtsItem(dat As Date)
If Dts.Exists(dat) Then
MsgBox "Duplicate key will not be added"
Else
Dim V
Set pSD = New cShiftData
With pSD
.GF = Me.GF
.GP = Me.GP
End With
Dts.Add dat, pSD
End If
End Function
Private Sub Class_Initialize()
Set pDts = New Dictionary
End Sub
Class Module
Option Explicit
'RENAME cDateData
Private pGP As Double
Private pGF As Double
Public Property Get GP() As Double
GP = pGP
End Property
Public Property Let GP(Value As Double)
pGP = Value
End Property
Public Property Get GF() As Double
GF = pGF
End Property
Public Property Let GF(Value As Double)
pGF = Value
End Property
Regular Module
Option Explicit
'SET REFERENCE TO: Microsoft Scripting Runtime
Sub reOrder()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim cSD As cShiftData, dSD As Dictionary
Dim I As Long, J As Long
Dim V As Variant, W As Variant
'set source and results worksheets
'read data into array
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
Set wsSrc = Worksheets("Sheet1")
V = LastRowCol(wsSrc.Name)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(V(0), V(1)))
End With
'collect the data
Set dSD = New Dictionary
For I = 1 To UBound(vSrc, 1)
If Not vSrc(I, 1) Like "*CODIGO*" And _
Len(vSrc(I, 1)) > 0 Then 'start of a new codigo
Set cSD = New cShiftData
With cSD
.Codigo = vSrc(I, 1)
.Nom = vSrc(I, 2)
.DNI = vSrc(I, 3)
dSD.Add Key:=.Codigo, Item:=cSD
End With
ElseIf Len(vSrc(I, 1)) = 0 Then
With cSD
.Dt = vSrc(I, 2)
.GP = vSrc(I, 4)
.GF = vSrc(I, 5)
dSD(.Codigo).addDtsItem (.Dt)
End With
End If
Next I
'create results array
'one line for each date
I = 0
For Each V In dSD.Keys
I = I + dSD(V).Dts.Count
Next V
ReDim vRes(0 To I, 1 To 6)
'Header row
vRes(0, 1) = "CODIGO NOMINA"
vRes(0, 2) = "NOM"
vRes(0, 3) = "D.N.I."
vRes(0, 4) = "FECHA"
vRes(0, 5) = "GP"
vRes(0, 6) = "GF"
I = 0
For Each V In dSD.Keys
With dSD(V)
For Each W In .Dts
I = I + 1
vRes(I, 1) = .Codigo
vRes(I, 2) = .Nom
vRes(I, 3) = .DNI
vRes(I, 4) = W
vRes(I, 5) = .Dts(W).GP
vRes(I, 6) = .Dts(W).GF
Next W
End With
Next V
'write the results
Application.ScreenUpdating = False
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.Columns(4).NumberFormat = "dd/mm/yyyy"
.Columns(1).HorizontalAlignment = xlCenter
With .EntireColumn
.ColumnWidth = 255
.AutoFit
End With
End With
myPivot wsRes
Application.ScreenUpdating = True
End Sub
Function LastRowCol(Worksht As String) As Long()
Application.Volatile
Dim WS As Worksheet, R As Range
Dim LastRow As Long, LastCol As Long
Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Not R Is Nothing Then
LastRow = R.Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
Original Data
reOrdered Data (after running macro)
Example Pivot Table
There is an excel issue where we have one column with values like below and we want the respective values to go into corresponding new columns like allocation, primary purpose etc.
data is like
Allocation: Randomized|Endpoint Classification: Safety/Efficacy Study|Intervention Model: Parallel Assignment|Masking: Double Blind (Subject, Caregiver)|Primary Purpose: Treatment
Allocation: Randomized|Primary Purpose: Treatment
Allocation: Randomized|Intervention Model: Parallel Assignment|Masking: Open Label|Primary Purpose: Treatment
There are many such rows like this.
First use text to columns to split data using | delimiter.
Assuming data layout as in screenshot:
Add the following in A6 and drag across/down as required:
=IFERROR(MID(INDEX(1:1,0,(MATCH("*"&A$5&"*",1:1,0))),FIND(":",INDEX(1:1,0,(MATCH("*"&A$5&"*",1:1,0))),1)+2,1000),"")
It uses the MATCH/INDEX function to get the text of cell containing the heading, then uses MID/FIND function to get the text after the :. The whole formula is then enclosed in IFERROR so that if certain rows do not contain a particular header item, it returns a blank instead of #N/A's
You did not ask for a VBA solution, but here is one anyway.
Determine the column headers by examining each line and generate a unique list of the headers, storing it in a dictionary
You can add a routine to sort or order the headers
Create a "results" array and write the headers to the first row, using the dictionary to store the column number for later lookup
examine each line again and pull out the value associated with each column header, populating the correct slot in the results array.
write the results array to a "Results" worksheet.
In the code below, you may need to rename the worksheet where the source data resides. The Results worksheet will be added if it does not already exist -- feel free to rename it.
Test this on a copy of your data first, just in case.
Be sure to set the reference to Microsoft Scripting Runtime (Tools --> References) as indicated in the notes in the code.
Option Explicit
'Set References
' Microsoft Scripting Runtime
Sub MakeColumns()
Dim vSrc As Variant, vRes As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim dHdrs As Dictionary
Dim V As Variant, W As Variant
Dim I As Long, J As Long
Set wsSrc = Worksheets("Sheet1")
'Get source data
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Set results sheet and range
On Error Resume Next
Set wsRes = Worksheets("Results")
If Err.Number = 9 Then
Worksheets.Add.Name = "Results"
End If
On Error GoTo 0
Set wsRes = Worksheets("Results")
Set rRes = wsRes.Cells(1, 1)
'Get list of headers
Set dHdrs = New Dictionary
dHdrs.CompareMode = TextCompare
'Split each line on "|" and then ":" to get header/value pairs
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "|")
For J = 0 To UBound(V)
W = Split(V(J), ":") 'W(0) will be header
If Not dHdrs.Exists(W(0)) Then _
dHdrs.Add W(0), W(0)
Next J
Next I
'Create results array
ReDim vRes(0 To UBound(vSrc, 1), 1 To dHdrs.Count)
'Populate Headers and determine column number for lookup when populating
'Could sort or order first if desired
J = 0
For Each V In dHdrs
J = J + 1
vRes(0, J) = V
dHdrs(V) = J 'column number
Next V
'Populate the data
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "|")
For J = 0 To UBound(V)
'W(0) is the header
'The dictionary will have the column number
'W(1) is the value
W = Split(V(J), ":")
vRes(I, dHdrs(W(0))) = W(1)
Next J
Next I
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
If you have not used macros before, to enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), opens the macro dialog box. Select the macro by name, and RUN.
I have some data in Excel file with some horizontal and vertical dimensions. It looks like this:
This data has to be loaded into some BI system. For this purpose I have to transform data to the "table style". In other words it should be presented in table like this:
I need some effective algorithm to make this transformation. The only one which I know is to take value from first cell (100000) get values from vertical and horizontal coordinates (Russia, Population, 1900) and insert into first row. Then take another cell and so on.
It would be work with small amount of data, but with big amount it works very slowly. Do you know more sophisticated algorithm for this kind of data?
There are several ways of doing this with VBA. In this solution, I first create a user defined Object named Country, with four properties: Name, Index, YR, and Quantity. It is not necessary to do this; but I've been working with these recently and I think it adds some clarity to the code.
I then read the Source data into a VBA array (which can be done in a single step), iterate through the array to create a collection of Country objects.
I then go through the Country collection, outputting the properties into a Results array, where I want them.
Finally, the results array is outputted to a worksheet -- again, just a single step.
One could go directly from the Source data array to the Results array, but I think it is easier to see what's going on using the object.
One could also not bother with the VBA array, but process the cells directly from one worksheet to another. In my experience, this approach will be at least an order of magnitude slower than using the VBA array approach.
Depending on the size of your database, refinements may be necessary. Be sure to read the comments in the code.
To define the Country object, insert a Class Module and rename it Country.
Place the following code in that module:
==========================================
Option Explicit
Private pName As String
Private pIndex As String
Private pYr As Long
Private pQuantity As Double
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get Index() As String
Index = pIndex
End Property
Public Property Let Index(Value As String)
pIndex = Value
End Property
Public Property Get Yr() As Long
Yr = pYr
End Property
Public Property Let Yr(Value As Long)
pYr = Value
End Property
Public Property Get Quantity() As Double
Quantity = pQuantity
End Property
Public Property Let Quantity(Value As Double)
pQuantity = Value
End Property
=============================================
Then, Insert a regular module and place this code there:
=======================================
Option Explicit
Sub TransformData()
Dim wsSrc As Worksheet 'Data Source
Dim wsRes As Worksheet, rRes As Range 'Results go here
Dim vSrc As Variant 'Actual data goes into this array
Dim vRes() As Variant 'Results will go here before being written to worksheet
Dim cCTY As Country 'User defined object
Dim colCountries As Collection
Dim I As Long, J As Long 'counters
Set wsSrc = Worksheets("Sheet2") '<--change these to whatever
Set wsRes = Worksheets("Sheet3")
Set rRes = wsRes.Range("A1") '<--1st cell of results array
'read data into array
With wsSrc
vSrc = .Range("A1").CurrentRegion '<--many ways to get this depending on your real data setup
End With
'iterate through Source and create collection of results
Set colCountries = New Collection
For I = 2 To UBound(vSrc, 1) '<--Rows
For J = 3 To UBound(vSrc, 2) '<--Columns
Set cCTY = New Country
With cCTY
.Name = vSrc(I, 1)
.Index = vSrc(I, 2)
.Yr = vSrc(1, J)
.Quantity = vSrc(I, J)
End With
colCountries.Add cCTY
Next J
Next I
'Results
ReDim vRes(0 To colCountries.Count, 1 To 4)
'Column Labels
vRes(0, 1) = "Country"
vRes(0, 2) = "Index"
vRes(0, 3) = "Year"
vRes(0, 4) = "Value"
For I = 1 To colCountries.Count
With colCountries(I)
vRes(I, 1) = .Name
vRes(I, 2) = .Index
vRes(I, 3) = .Yr
vRes(I, 4) = .Quantity
End With
Next I
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes
With rRes.Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
rRes.EntireColumn.AutoFit
End Sub
====================================================
Ensure the worksheets and ranges are properly defined to accord with your real setup, and run the macro.