I am working on a sub which will take data from one table (HeadsTable) and fill it into the appropriate place in another table (AllocatedHeads). The HeadsTable contains headcount data by year. These headcounts need to be split by a number of stakeholders and funding types. The AllocatedHeads table will have a row for each stakeholder and funding type so one entry in the HeadsTable corresponds to multiple in the AllocatedHeads table(up to 30). The headcounts themselves I am filling in with excel formulas, but I want the macro to fill in all of the decriptive data from the heads table.
I have created a HeadsEntry Class which holds all of the field data for an entry from HeadsTable and a HeadsCollection Class which is just a collection of all of the HeadsEntry Objects.
I am happy to show my entire sub, but what is shown here relates to my efforts to fill the table by iterating over the HeadsCollection. The code below is functional, but takes a REALLY long time. Hours. My first attempt also worked and is shown in the comments. It also took hours to run.
Is there a way I can accomplish this task in a more reasonable run time?
Dim AbsRow As Long
If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
'clear table, add one row, get row value
[AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
[AllocatedHeads].ListObject.ListRows.Add
AbsRow = [AllocatedHeads].ListObject.ListRows(1).Range.Row
End If
'dimension field column variables
Dim DescriptionCol As Integer
Dim LMWBSCol As Integer
Dim Org1Col As Integer
Dim Org2Col As Integer
Dim Org3Col As Integer
Dim PALS_OSsplitCol As Integer
Dim ServiceShareRuleCol As Integer
Dim Heads_IDCol As Integer
Dim PALS_OSCol As Integer
Dim ServiceCol As Integer
'assign column values to variables
DescriptionCol = [AllocatedHeads[Description]].Column
LMWBSCol = [AllocatedHeads[LM WBS]].Column
Org1Col = [AllocatedHeads[Org Tier 1]].Column
Org2Col = [AllocatedHeads[Org Tier 2]].Column
Org3Col = [AllocatedHeads[Org Tier 3]].Column
PALS_OSsplitCol = [AllocatedHeads[PALS/O&S Split]].Column
ServiceShareRuleCol = [AllocatedHeads[Service Share Rule]].Column
Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
ServiceCol = [AllocatedHeads[Service]].Column
' RowNum = 1
For Each Entry In HeadsCollection.Entries
For i = 1 To UBound(Entry.PALSOS)
For j = 1 To UBound(Entry.Service)
' [AllocatedHeads].ListObject.ListRows.Add
' AbsRow = [AllocatedHeads].ListObject.ListRows(RowNum).Range.Row
Cells(AbsRow, DescriptionCol) = Entry.Description
Cells(AbsRow, LMWBSCol) = Entry.LMWBS
Cells(AbsRow, Org1Col) = Entry.Org1
Cells(AbsRow, Org2Col) = Entry.Org2
Cells(AbsRow, Org3Col) = Entry.Org3
Cells(AbsRow, PALS_OSsplitCol) = Entry.PALSOSsplit
Cells(AbsRow, ServiceShareRuleCol) = Entry.ServiceRule
Cells(AbsRow, Heads_IDCol) = Entry.ID
Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
AbsRow = AbsRow + 1
' Set RowRange = [AllocatedHeads].ListObject.ListRows(RowNum).Range
' Intersect(RowRange, [AllocatedHeads[Description]]) = Entry.Description
' With Intersect(RowRange, [AllocatedHeads[LM WBS]])
' .value = Entry.LMWBS
' .NumberFormat = "#"
' End With
' Intersect(RowRange, [AllocatedHeads[Org Tier 1]]) = Entry.Org1
' Intersect(RowRange, [AllocatedHeads[Org Tier 2]]) = Entry.Org2
' Intersect(RowRange, [AllocatedHeads[Org Tier 3]]) = Entry.Org3
' Intersect(RowRange, [AllocatedHeads[PALS/O&S Split]]) = Entry.PALSOSsplit
' Intersect(RowRange, [AllocatedHeads[Service Share Rule]]) = Entry.ServiceRule
' Intersect(RowRange, [AllocatedHeads[Heads_ID]]) = Entry.ID
' Intersect(RowRange, [AllocatedHeads[PALS/O&S]]) = Entry.PALSOS(i - 1)
' Intersect(RowRange, [AllocatedHeads[Service]]) = Entry.Service(j - 1)
' RowNum = RowNum + 1
Next j
Next i
Next Entry
My solution was to convert to a range, fill in the cells, and convert back to a table. Filling in cells in a range is MUCH quicker than in a table. I also took advantage of the fact that filling in the first cell in a table column turns it into a calculated field. By using formulas in those fields I reduced the number of fields I was storing in my Entry object and the number of cells I needed to fill in. I am sure that there are much faster ways, but this solution brings it down from hours to under a minute, which is good enough for my needs. The code beow doesn't show the entire sub, only the relevant portion.
'determine needed size for Allocated heads table
AllocatedHeadsRowCount = 0
For Each Entry In HeadsCollection.Entries
AllocatedHeadsRowCount = AllocatedHeadsRowCount + (UBound (Entry.PALSOS) * UBound(Entry.Service))
Next Entry
'determine Absolute row (sheet row, instead of listobject row) of first row in table
Dim AbsRow As Long
AbsRow = [AllocatedHeads].ListObject.HeaderRowRange.Row + 1
'delete all table rows
If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
'clear table, add one row, get row value
[AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
End If
'assign number values of header row, first table column, number of column
AllocatedHeadsStartRow = [AllocatedHeads].ListObject.HeaderRowRange.Row
AllocatedHeadsStartColumn = [AllocatedHeads].ListObject.HeaderRowRange.Column
AllocatedNumberofColumns = [AllocatedHeads].ListObject.HeaderRowRange.Columns.Count
'dimension field column variables
Dim Heads_IDCol As Integer
Dim PALS_OSCol As Integer
Dim ServiceCol As Integer
'assign column values to variables
Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
ServiceCol = [AllocatedHeads[Service]].Column
'convert table to range because filling cells in a range is MUCH faster than in a table
[AllocatedHeads].ListObject.Unlist
'fill ID, PALS/O&S, and Service columns
For Each Entry In HeadsCollection.Entries
For i = 1 To UBound(Entry.PALSOS)
For j = 1 To UBound(Entry.Service)
Cells(AbsRow, Heads_IDCol) = Entry.ID
Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
AbsRow = AbsRow + 1
Next j
Next i
Next Entry
'convert back to table
With Sheets("Allocated Heads").ListObjects.Add(xlSrcRange, Range(Cells(AllocatedHeadsStartRow, AllocatedHeadsStartColumn), Cells(AllocatedHeadsStartRow + AllocatedHeadsRowCount, AllocatedHeadsStartColumn + AllocatedNumberofColumns - 1)), , xlYes)
.Name = "AllocatedHeads"
.TableStyle = "TableStyleMedium7"
End With
'add formulas to the first cell in columns for which the data is the same as in the heads table.
'This creates a calculated column and will fill down
[AllocatedHeads].ListObject.ListColumns("Service Share Rule").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Service Share Rule]:[Service Share Rule]])"
[AllocatedHeads].ListObject.ListColumns("PALS/O&S Split").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[PALS/O&S Split]:[PALS/O&S Split]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 1").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 1]:[Org Tier 1]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 2").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 2]:[Org Tier 2]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 3").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 3]:[Org Tier 3]])"
[AllocatedHeads].ListObject.ListColumns("LM WBS").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[LM WBS]:[LM WBS]])"
[AllocatedHeads].ListObject.ListColumns("Description").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Description]:[Description]])"
[AllocatedHeads].ListObject.ListColumns("2009").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[2009])*SUMPRODUCT((AllocatedHeads[#[PALS/O&S Split]:[PALS/O&S Split]] = SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[#[PALS/O&S]:[PALS/O&S]] = SplitTable[[PALS/O&S]:[PALS/O&S]])*SplitTable[2009])*SUMPRODUCT((AllocatedHeads[#[Service Share Rule]:[Service Share Rule]]=SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[#[Service]:[Service]]=SplitTable[[Service]:[Service]])*SplitTable[2009])"
'Fill years columns by first drragging across(to have appropriate column references),
'then copy pasting in place in order to create calculated columns
Dim FirstCell As Range
Dim FillRange As Range
Set FirstCell = Intersect([AllocatedHeads].ListObject.DataBodyRange.Rows(1), [AllocatedHeads[2009]])
Set FillRange = Range(FirstCell.Address, Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column))
FirstCell.AutoFill FillRange, xlFillDefault
FillRange.Copy
FirstCell.PasteSpecial xlPasteFormulas
'create calculated column in Total column
[AllocatedHeads].ListObject.ListColumns("Total").DataBodyRange = "=SUM(" & FirstCell.Address(False, False) & ":" & Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column).Address(False, False) & ")"
Related
Original Post: Data being indexed in the dictionary is verified to have no duplicate values in the index column. Data in range has format: col 1 = index(string) | col 2 = value(double)All values set to 0 prior to runtime of this section of codeError trapping is set to "Break on Unhandled Errors"
Why am I getting this error? I can't spot anything that would throw a duplicate into the dictionary. (Sorry, I'm not a developer.)
Update:
No longer getting the duplicate key error, but now seeing values added to the dictionary (and subsequently output) as keys, in addition to the desired index keys. Apologies if this is a big ol' bowl of spaghetti.
Full code below
Sub CompileActuals()
' Get it started
Dim ibh As Integer
Dim pah As Integer
Dim WrkSht As Worksheet
Dim RngB As Range
Dim RngA As Range
Dim CLine As Object
Dim CLineData As Class1
Dim im As Integer
Dim cm As Integer
Dim vpah As Integer
Dim vibh As Integer
Dim vMonth As Integer
Dim vO As Integer
Dim LineWeight As Double
Dim varIndex As Variant
ibh = Sheets("GCM Compiler").Cells(1, 6)
pah = Sheets("GCM Compiler").Cells(2, 6)
im = Sheets("GCM Compiler").Cells(3, 4)
cm = Sheets("GCM Compiler").Cells(1, 4)
Set WrkSht = ThisWorkbook.Worksheets("GCM Compiler")
Set RngB = WrkSht.Range(Cells(9, 4 + (2 * im)), Cells(1563, 5 + (2 * im)))
Set RngA = WrkSht.Range(Cells(9, 3), Cells(8 + pah, 4))
Set CLine = CreateObject("Scripting.Dictionary")
' Wipe Budget Numbers
Range(Cells(9, (5 + (2 * im))), Cells(8 + ibh, 5 + (2 * im))).Value = 0
' Clear the Dictionary
CLine.RemoveAll
' Fill dictionary with zeros for the existing indices
For vibh = 1 To ibh
' Set each row's variables
varIndex = RngB.Cells(vibh, 1).Value
LineWeight = CDbl(RngB.Cells(vibh, 2).Value)
vMonth = cm
' Test for index already exists in dictionary
If CLine.Exists(varIndex) Then
' Get existing index entry's properties
Set CLineData = CLine(varIndex)
' Add weight of that line to the index entry
CLineData.Weight = 0
Else
' Create an entry for the new index
Set CLineData = New Class1
' Set properties of the new entry
CLineData.Weight = LineWeight
CLineData.Month = vMonth
CLineData.Index = varIndex
' Store the new entry in the dictionary
CLine.Add varIndex, CLineData
End If
Next vibh
' Add actuals, iterate thru pasted actual values
For vpah = 1 To pah
' Set each row's variables
varIndex = RngA.Cells(vpah, 1).Value
LineWeight = CDbl(RngA.Cells(vpah, 2).Value)
vMonth = cm
' Test for index already exists in dictionary
If CLine.Exists(varIndex) Then
' Get existing index entry's properties
Set CLineData = CLine(varIndex)
' Add weight of that line to the index entry
CLineData.Weight = CLineData.Weight + CDbl(RngA.Cells(vpah, 2))
Else
' Create an entry for the new index
Set CLineData = New Class1
' Set properties of the new entry
CLineData.Weight = LineWeight
CLineData.Month = vMonth
CLineData.Index = varIndex
' Store the new entry in the dictionary
CLine.Add varIndex, CLineData
End If
Next vpah
' Output Compiled Weights
For vO = 0 To CLine.Count - 1
Set CLineData = CLine.Items()(vO)
WrkSht.Cells(9 + vO, 4 + (2 * im)).Value = CLineData.Index
WrkSht.Cells(9 + vO, 5 + (2 * im)).Value = CLineData.Weight
Next vO
'
End Sub
Data comes in in two ranges, budget and actuals. The goal of the code is to replace the budget with zeros then compile actuals of existing key items and of new key items and add the data to the original location of the budget data.
Both the actuals and the budget input data ranges will look something like this with index in the first column and associated value in the second column:
Key 1 | Value
Key 2 | Value
Key 3 | Value
Key 1 | Value
Key 4 | Value
Just use something like this:
If Not .Exists(SomeKey) Then
.Add SomeKey, SomeValue
Else
stop 'Go investigate what someKey is
End If
Also I suggest checking out the excellent article at https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html
I am trying to write a VBA code to work within excel which will do the following:
I need to search through a column to find a date, once it is found I need 3 variables in that row to be copied over to another sheet in the same workbook. This is metocean data retrieved from the public domain, so dates are in order.
Below I've written a code which in my opinion SHOULD do the job, but for some reason only returns the first occurrence of the date which is used as input. I need it to copy the remaining days' code as well (ex. copy date corresponding to all the "January2"s in the data set).
Sub DataRetrieve()
Dim MDCount As Long
MDCount = 2
Dim OutputCount As Long
OutputCount = 5
Dim TimespanCount As Integer
TimespanCount = 0
Dim TimespanDAY As Range
Set TimespanDAY = Worksheets("TOOL").Cells((TimespanCount + 9), 5)
Dim HourCount As Integer
HourCount = 0
Dim Timespan As Range
Set Timespan = Worksheets("TOOL").Cells(6, 6)
Dim i As Integer
i = 0
'-------------------------------------------------------------------------------
Do Until Worksheets("DATA").Cells(MDCount, 15) = "END"
If TimespanDAY.Text = DayRead.Text Then
Do Until HourCount = 24
Worksheets("TEMP").Cells(OutputCount, 2) = Worksheets("DATA").Cells(MDCount, 7).Value
Worksheets("TEMP").Cells(OutputCount, 3) = Worksheets("DATA").Cells(MDCount, 8).Value
Worksheets("TEMP").Cells(OutputCount, 4) = Worksheets("DATA").Cells(MDCount, 9).Value
MDCount = MDCount + 1
OutputCount = OutputCount + 1
HourCount = HourCount + 1
Loop
End If
MDCount = MDCount + 1
Set DayRead = Worksheets("DATA").Cells(MDCount, 4)
Set TimespanDAY = Worksheets("TOOL").Cells((TimespanCount + 9), 5)
Loop
End Sub
Ideally, I'd like to expand this (once it works) to then restart the loop and go to the next corresponding date (ex. January3) do the exact same thing, and store in another column on the same sheet where the last data was stored.
I can explain more clearly if necessary. I appreciate any help! This is for a school project so time is of essence.
Andrew
I have an Excel sheet (InData) which has individual rows of data by unique "ID NUMBER". Each ID Number may have multiple "deductions" and "benefits" contained in the one row. But I need to convert the single row of data into multiple rows by ID Number and write the results into a new sheet (OutData).
I tried to attach my sample Excel file but can't find way to do it. So attached sample images for InData and OutData.
This is InData...
This is OuData...
Below is code I'm using.
Option Explicit
'Found original VBA here...
'http://stackoverflow.com/questions/3698442/convert-row-with-columns-of-data-into-column-with-multiple-rows-in-excel
Sub reOrgV2_New(inSource As Range, inTarget As Range)
'' This version works directly on the worksheet
'' and transfers the result directly to the target
'' given as the top-left cell of the result.
Dim resNames()
Dim propNum As Integer
Dim srcRows As Integer
Dim resRows As Integer
Dim i As Integer
Dim j As Integer
Dim g As Integer
'' Shape the result
resNames = Array("Deduction Desc", "Deduction Amount", "Deduction Start Date", "Deduction Stop Date", _
"Benefit Desc", "Benefit Amount", "Benefit Start Date", "Benefit Stop Date")
propNum = 1 + UBound(resNames)
'' Row counts
srcRows = inSource.Rows.Count
resRows = srcRows * propNum
'' re-org and transfer source to result range
inTarget = inTarget.Resize(resRows, 7)
g = 1
For i = 1 To srcRows
For j = 0 To 7
inTarget.Item(g + j, 1) = inSource.Item(i, 1) '' ID NUMBER
inTarget.Item(g + j, 2) = inSource.Item(i, 2) '' LAST NAME
inTarget.Item(g + j, 3) = inSource.Item(i, 3) '' FIRST NAME
inTarget.Item(g + j, 4) = resNames(j) '' Column Type
inTarget.Item(g + j, 5) = inSource.Item(i, j + 4) '' Value
Next j
g = g + propNum
Next i
End Sub
'' Call ReOrgV2_New with input and output ranges
Sub ReOrg_New()
Dim ws As Worksheet
Dim i As Integer
i = Range("InData!A:A").Find("").Row - 2
reOrgV2_New Range("InData!A2").Resize(i, 7), [OutData!A2]
With Sheets("OutData")
'We select the sheet so we can change the window view
.Select
'' apply column headings and autofit/align
.Range("A1:E1").Value = Array("ID NUMBER", "LAST NAME", "FIRST NAME", "Column Type", "Value")
.Columns("A:E").EntireColumn.AutoFit
.Columns("E:E").HorizontalAlignment = xlRight
End With
End Sub
Pertinent to your task definition, it seems that you can achieve the result simply by deletion of the unnecessary Worksheet Columns, which could be performed as, for example: Columns("H").Delete, or Columns(7).EntireColumn.Delete and so on (see the following sample VBA code snippet):
Sub DeleteColumns()
'delete columns
Columns("AR:AU").Delete
Columns("H:AL").Delete
' re-arrange columns order
Columns("D").Cut
Columns("F").Insert Shift:=xlToRight
End Sub
Then you can just re-arrange the order of residual data columns.
Hope this may help.
I have a row of data as follows:
header1 header2 header3 header4 header5
row key datavalue1 datavalue2 datavalue3 datavalue4 datavalue5....
CC Corporate Leadership Community Funding Delivery
da1000 50% 50%
so basically, I have a denormalized data set where the datavalues may or may not be empty on a row-by-row basis. I need to normalize them.
ie
CC Activity Allocation
da1000 Community Development 50%
da1000 Community Funding Delivery 50%
etc
I could do this by using a paste special transform, but I have thousands of rows and I'd need to make sure that I get the right row key for each. furthermore, each row has a bunch of descriptives associated with it that I need copied over with each datavalue.
I have tried to use the following code however I'm getting a
Run-time Error 5
Invalid procedure call or argument
Sub NormalizeSheet()
Dim wsOriginal As Worksheet
Dim wsNormalized As Worksheet
Dim strKey As String
Dim clnHeader As Collection
Dim lngColumnCounter As Long
Dim lngRowCounterOriginal As Long
Dim lngRowCounterNormalized As Long
Dim rngCurrent As Range
Dim varColumn As Variant
Set wsOriginal = ThisWorkbook.Worksheets("Original") 'This is the name of your original worksheet'
Set wsNormalized = ThisWorkbook.Worksheets("Normalized") 'This is the name of the new worksheet'
Set clnHeader = New Collection
wsNormalized.Cells.ClearContents 'This deletes the contents of the destination worksheet'
lngColumnCounter = 2
lngRowCounterOriginal = 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
' We'll loop through just the headers to get a collection of header names'
Do Until IsEmpty(rngCurrent.Value)
clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter)
lngColumnCounter = lngColumnCounter + 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
Loop
'Here we'll reset our Row Counter and loop through the entire data set'
lngRowCounterOriginal = 2
lngRowCounterNormalized = 1
lngColumnCounter = 1
Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
strKey = rngCurrent.Value ' Get the key value from the current cell'
lngColumnCounter = 2
'This next loop parses the denormalized values for each row'
Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
'We're going to check to see if the current value'
'is equal to NULL. If it is, we won't add it to'
'the Normalized Table.'
If rngCurrent.Value = "NULL" Then
'Skip it'
Else
'Add this item to the normalized sheet'
wsNormalized.Range("A" & lngRowCounterNormalized).Value = strKey
wsNormalized.Range("B" & lngRowCounterNormalized).Value = clnHeader(CStr(lngColumnCounter))
wsNormalized.Range("C" & lngRowCounterNormalized).Value = rngCurrent.Value
lngRowCounterNormalized = lngRowCounterNormalized + 1
End If
lngColumnCounter = lngColumnCounter + 1
Loop
lngRowCounterOriginal = lngRowCounterOriginal + 1
lngColumnCounter = 1 'We reset the column counter here because we're on a new row'
Loop
End Sub (CREDIT GOES TO Ben McCormack)
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