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.
Related
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#)
Looking for a more appropriate approach. I have a working solution, but it seems there should be a built-in or more elegant method.
I am comparing two sheets from separate workbooks, documenting the differences on a sheet in current workbook. Every time a difference is found, I'm generating a row of output data. As I'm unaware of the total number of differences I will find, the row of output data is appended to an ArrayList.
I have a working bit of code, but the effective method is:
Create a row as an arraylist.
Convert the row to an array.
Add the row to an arraylist for output
TWICE Transpose the output arraylist while converting to an array
Output the array to worksheet.
With all the benefit of using ArrayLists, it seems that there should be a direct method for outputting a 2D "ArrayList of ArrayLists" or something along those lines.
Here is the current code:
Sub findUnmatchingCells()
Dim oWB_v1 As Workbook, oWB_v2 As Workbook, oRange_v1 As Range, oRange_v2 As Range
On Error GoTo endofsub
With Me
.Cells.Clear
.Cells(1, 1) = "Row"
.Cells(1, 2) = "Column"
.Cells(1, 3) = "v1"
.Cells(1, 4) = "v2"
End With
Dim missing_items As Object
Dim output_row(), output(), missing_row As Object
Set oWB_v1 = Workbooks("foo.xls")
Set oWB_v2 = Workbooks("bar.xls")
Set oRange_v1 = oWB_v1.Sheets(1).Range("A1:AD102")
Set oRange_v2 = oWB_v2.Sheets(1).Range("A1:AD102")
Set missing_items = CreateObject("System.Collections.ArrayList")
For rRow = 1 To oRange_v1.Rows.Count
For cCol = 1 To oRange_v1.Columns.Count
If oRange_v1.Cells(rRow, cCol) <> oRange_v2.Cells(rRow, cCol) Then
Set missing_row = CreateObject("System.Collections.ArrayList")
missing_row.Add rRow
missing_row.Add cCol
missing_row.Add oRange_v1.Cells(rRow, cCol).Value2
missing_row.Add oRange_v2.Cells(rRow, cCol).Value2
output_row = missing_row.toarray
missing_items.Add output_row
End If
Next cCol
Next rRow
output = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(missing_items.toarray))
'my own output routine
If Not outputArrayToRange(output, Me.Range("A2")) Then Stop
Exit Sub
endofsub:
Debug.Print rRow, cCol, missing_items.Count, missing_row.Count, Error
Stop
End Sub
Seems like a lot of extra work here with ArrayList when you are not really using anything useful from them. As you know the mismatch count cannot be more than the number of start elements, and the columns will be 4 at end, you can do all of this just with a single array. Pre-size the array and in your loop populate it.
Simplified example:
As you are using Me this code would be in "Sheet1".
Now it would get more complicated if you wanted to ReDim to actual number of mismatches to avoid over-writing something, but generally it is wise to plan developments to avoid such risks. You would need the double transpose to be able to ReDim the rows as columns then back to rows.
With the ranges you mention I don't think the Transpose limit would be an issue, but that is a concern in other cases which needs to be resolved with additional looping.
The efficient way is to use arrays the whole time. Read the two ranges into arrays, loop one and compare against the other, write out changes to pre-sized array, write array to sheet
If this is just about is there nicer functionality for this within ArrayLists, no. What you have done is short and effective but incurs more overhead than is necessary.
Option Explicit
Public Sub findUnmatchingCells()
Dim oWB As ThisWorkbook, oRange_v1 As Range, oRange_v2 As Range
With Me
.Cells.Clear
.Cells(1, 1) = "Row"
.Cells(1, 2) = "Column"
.Cells(1, 3) = "v1"
.Cells(1, 4) = "v2"
End With
Dim rRow As Long, cCol As Long
Set oWB = ThisWorkbook
Set oRange_v1 = oWB.Worksheets("Sheet2").Range("A1:D3") 'would be faster to read this into array and later loop that
Set oRange_v2 = oWB.Worksheets("Sheet3").Range("A1:D3") 'would be faster to read this into array and later loop that
Dim totalElements As Long, output()
totalElements = oRange_v1.Rows.Count * oRange_v1.Rows.Count
ReDim output(1 To totalElements, 1 To 4)
For rRow = 1 To oRange_v1.Rows.Count 'would be faster to loop arrays than sheet
For cCol = 1 To oRange_v1.Columns.Count
If oRange_v1.Cells(rRow, cCol) <> oRange_v2.Cells(rRow, cCol) Then
output(rRow, 1) = rRow
output(rRow, 2) = cCol
output(rRow, 3) = oRange_v1.Cells(rRow, cCol).Value2
output(rRow, 4) = oRange_v2.Cells(rRow, cCol).Value2
End If
Next cCol
Next rRow
oWB.Worksheets("Sheet1").Cells(2, 1).Resize(UBound(output, 1), UBound(output, 2)) = output
End Sub
Other thoughts:
You can have early bound if adding references is not a concern:
From: https://www.snb-vba.eu/VBA_Arraylist_en.html
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
or
ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
You are wasting an already created object by continually re-creating your missing_row ArrayList within loop. Create it once, before the loop, and just before you loop round again call the .Clear method.
I am pretty new to VBA, and I would like to fill a collection with a range of cells from a worksheet. I later will want to add and subtract line items, so I need it to dynamically include all rows I need in columns 1, 2, and 3. I then need to call the function that fills the collection to fill some different combo boxes but I only want to fill the combo box with the first two columns of the collection. I would like the first column to be the key for each line item in the collection.
I have read a good bit online but I am repeatedly getting the Runtime error 91: object variable or with block variable not set. In addition I seem to be having trouble actually calling the collection function in my userform sub. This may have something to do with the structure of my code but I cannot figure out what. This may be basic but I have been trying to figure it out for quite a while and have not been able to.
Dim cCodes As Collection
Function getCodes() As Collection
Set cCodes = New Collection
Dim rRange As Range
Dim rRow As Range
Set getCodes = New Collection
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.Activate
Let rRange = Range("A4:C4")
Let rRow = Range(rRange, rRange.End(xlDown))
For Each rRange In rRow
cCodes.Add rRange.Cells(0, 0), rRange.Cells(0, 1), rRange.Cells(0, 2),
Key:=rRange.Cells(0, 1)
Let rRange = rRange.Offset(1, 0)
Next rRange
Set getCodes = cCodes
End Function
Private Sub UserForm_Initialize()
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
Dim cCodes As Collection
Set cCodes = getCodes
With UserForm1
CostCode1.List = cCodes
CostCode2.List = cCodes
CostCode3.List = cCodes
CostCode4.List = cCodes
CostCode5.List = cCodes
CostCode6.List = cCodes
End With
......more userform code
End Sub
I want it to run smoothly, for the collection to be global and always be updated with all line items in the columns specified (stop at first empty row). I will also want to use this collection in other places so need to be able to call it. Please let me know what I am doing wrong
I wouldn't use a global variable. It is a bad practice and prone to errors. Instead I'd call a Sub to build the collection and use it later like this:
Option Explicit
Sub getCodes(cCodes As Collection)
Set cCodes = New Collection
Dim rRange As Range
Dim rRow As Range
Set getCodes = New Collection
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.Activate
Let rRange = Range("A4:C4")
Let rRow = Range(rRange, rRange.End(xlDown))
For Each rRange In rRow
cCodes.Add rRange.Cells(0, 0), rRange.Cells(0, 1), rRange.Cells(0, 2), Key:=rRange.Cells(0, 1)
Let rRange = rRange.Offset(1, 0)
Next rRange
End Sub
Private Sub UserForm_Initialize()
Dim cCodes As Collection
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
getCodes cCodes
With UserForm1
CostCode1.List = cCodes
CostCode2.List = cCodes
CostCode3.List = cCodes
CostCode4.List = cCodes
CostCode5.List = cCodes
CostCode6.List = cCodes
End With
......more userform code
End Sub
So you declare only once your variable on the main sub, I think in your example that's UserForm_Initalize once you declare it there, you can pass cCodes to getCodes like this: getCodes cCodes and the procedure will build your collection ready to be used on the main procedure or the ones to come if used the same way.
Another tip is to use Option Explicit which will force you to declare all your variables and your code will be better built.
I much prefer Dictionaries over Collections. They both server functionally the same purpose, but I find Dictionaries offer advantages in terms of performance and ease of use. That being said, I think something like this is what you're looking for. This is, admittedly, fairly advanced so I commented the code to help with following what it's doing:
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim rData As Range
Dim hCodes As Object
Dim vKey As Variant
Dim aCols As Variant
'This is the sheet that contains the data you wanted to get the codes from
Set ws = ThisWorkbook.Worksheets("Sheet1")
'This is the range containing the codes on that sheet
Set rData = ws.Range("A4:C" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
'Create the dictionary object
Set hCodes = CreateObject("Scripting.Dictionary")
'Specify the columns you want to use for the comboboxes (1 is the first column, 2 is the second column, etc.)
'It doesn't have to be consecutive, if you want 1st and 3rd columns for example you could specify Array(1, 3)
aCols = Array(1, 2)
'Populate the dictionary using the GetCodes function (see below)
Set hCodes = GetCodes(rData, 2) 'First argument is the range to pull the codes from, the second argument is the column that contains the keys
'Loop through each key in the populated dictionary
For Each vKey In hCodes.Keys
'Populate the correct combobox based on the key (these are examples, change to what your actual keys and comboboxes will be)
'See below for the PopulateList function;
' first argument is the listbox that should be populated
' second argument is the full array of values that the list will be populated from
' third argument is the list of column numbers that will be used to pull from the provided array values
Select Case vKey
Case "a": PopulateList Me.ComboBox1, hCodes(vKey), aCols
Case "b": PopulateList Me.ComboBox2, hCodes(vKey), aCols
Case "c": PopulateList Me.ComboBox3, hCodes(vKey), aCols
Case "d": PopulateList Me.ComboBox4, hCodes(vKey), aCols
Case "e": PopulateList Me.ComboBox5, hCodes(vKey), aCols
Case "f": PopulateList Me.ComboBox6, hCodes(vKey), aCols
End Select
Next vKey
End Sub
Private Function GetCodes(ByVal arg_rData As Range, Optional ByVal arg_lKeyCol As Long = 1) As Object
'Verify the range provided and key column provided are valid
If arg_rData.Areas.Count > 1 Then
MsgBox "Invalid range provided: " & arg_rData.Address & Chr(10) & "Must be a contiguous range"
Exit Function
ElseIf arg_rData.Columns.Count < arg_lKeyCol Or arg_lKeyCol < 1 Then
MsgBox "Key Column must be >= 1 and <= Provided range's column count"
Exit Function
End If
Dim hResult As Object
Dim hIndices As Object
Dim aData() As Variant
Dim aTemp() As Variant
Dim ixNew As Long
Dim ixData As Long
Dim ixCol As Long
'Prepare the data array
If arg_rData.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = arg_rData.Value
Else
aData = arg_rData.Value
End If
'Prepare the result dictionary, and use an Indices dictionary to keep track of where data should be loaded in it
Set hResult = CreateObject("Scripting.Dictionary")
Set hIndices = CreateObject("Scripting.Dictionary")
'Loop through each row of the provided data range (we loaded it into the data array earlier)
For ixData = 1 To UBound(aData, 1)
'Check if the key already exists
If hResult.Exists(aData(ixData, arg_lKeyCol)) Then
'Key already exists, update the index so we know which row to populate to in the results
hIndices(aData(ixData, arg_lKeyCol)) = hIndices(aData(ixData, arg_lKeyCol)) + 1
Else
'Key does not exist, prepare a result array for it in the Results dictionary and set the Index to 1
ReDim aTemp(1 To WorksheetFunction.CountIf(arg_rData.Columns(arg_lKeyCol), aData(ixData, arg_lKeyCol)), 1 To UBound(aData, 2))
hResult(aData(ixData, arg_lKeyCol)) = aTemp
hIndices(aData(ixData, arg_lKeyCol)) = 1
End If
'Clear the temp array and assign it to the current key's array
Erase aTemp
aTemp = hResult(aData(ixData, arg_lKeyCol))
'Loop through each column in the data array
For ixCol = 1 To UBound(aData, 2)
'Populate the temp array with the current value from the data array
aTemp(hIndices(aData(ixData, arg_lKeyCol)), ixCol) = aData(ixData, ixCol)
Next ixCol
'Set the appropriate Key of the Results dictionary to the temp array
hResult(aData(ixData, arg_lKeyCol)) = aTemp
Next ixData
'Set the function's output the Results dictionary
Set GetCodes = hResult
End Function
Private Sub PopulateList(ByVal arg_cComboBox As Control, ByVal arg_aData As Variant, ByVal arg_aColNums As Variant)
Dim aList As Variant
Dim vCol As Variant
Dim i As Long, j As Long
'Prepare the list array
ReDim aList(LBound(arg_aData, 1) To UBound(arg_aData, 1), 1 To UBound(arg_aColNums) - LBound(arg_aColNums) + 1)
'Loop through each row of the provided data array
For i = LBound(arg_aData, 1) To UBound(arg_aData, 1)
j = 0
'Loop through only the column numbers provided
For Each vCol In arg_aColNums
'Populate the list array with the correct item from the data array
j = j + 1
aList(i, j) = arg_aData(i, vCol)
Next vCol
Next i
'Clear previous list, set the column count, and set the list to the now populated list array
With arg_cComboBox
.Clear
.ColumnCount = UBound(aList, 2)
.List = aList
End With
End Sub
This is not tested, but you can fill a combobox with an array:
Option Explicit
Function getCodes() as Variant ' intent is to return an array.
Dim rRange As Range
Let rRange = ThisWorkbook.Worksheets("Sheet1").Range("A4:C4") ' fully qualified.
Let rRange = Range(rRange, rRange.End(xlDown))
getCodes = rRange.Value ' return a 2D array that is three columns wide.
End Function
Private Sub UserForm_Initialize()
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
With UserForm1
CostCode1.List = getCodes
CostCode2.List = getCodes
CostCode3.List = getCodes
CostCode4.List = getCodes
CostCode5.List = getCodes
CostCode6.List = getCodes
End With
......more userform code
End Sub
The use of a function instead of rolling those few lines into the main code will help future extension (e.g. adding parameters to the function to change the range where the codes are stored).
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.