Macros to sum unique values related to another column - excel

I need to create macros to populate in "Metrics calculator" tab, the sum of "No of test steps"(Column G) for each "study" (Column D). The sum should consider unique values only. Please see the table below:
In this Study no '1111', total step no/patient no '20' repeated 3 times, '15' repeated 4 times and '30' 3 times- i need the macros just to take unique values and add,i.e just 20+15+30=65.
In Metrics calculator tab"- It should come with output as
Study no Total no of steps
1111 65

So if I understand the question, you want to sum the unique values in column B. The following will do the trick.
Note, you will need to adgust the range as necessary. Right now the range is set to B2:B20 as in your sample table.
Sub unique()
Dim arr() As Variant
Dim arrElem As Variant
Dim Rng As Range
Dim elem As Range
Dim i As Long
Dim stepSum As Long
Dim match As Boolean
Set Rng = Range("B2:B20") 'Edit this so that it fits your array
'this sets up an array to store unique variables
ReDim Preserve arr(1 To 1) As Variant
arr(1) = 0
'this loops through each number in the identified range
For Each elem In Rng
'this is a boolean, false means the current number is unique (so far) true means the number has been seen previously.
match = False
'this checks the current number against all the unique values stored in the array
For Each arrElem In arr
'If it finds a match, it changes the boolean to true
If arrElem = elem Then match = True
Next arrElem
'If not match was found, we store the current number as a new unique value in the array
If match = False Then
'this adds another row to the array
ReDim Preserve arr(1 To UBound(arr) + 1) As Variant
'this adds the unique value
arr(UBound(arr)) = elem.Value
End If
Next elem
'this sums the unique numbers we stored in the array
For i = 1 To UBound(arr)
stepSum = stepSum + arr(i)
Next i
'this reports the sum of unique elements
MsgBox stepSum
End Sub

Review this example :
In our sample ,cells(vendor names) in "column B" are listed as unique values into "column K" :
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Columns( _
"B:B"), CopyToRange:=Range("'Sheet1'!K1"), Unique:=True
Later , to sum these items(amounts in column I) in column "L" ,we entered SUMIF formula to cells in column L using a loop :
For i = 2 To Cells(Rows.Count, 11).End(xlUp).Row
Cells(i, "L").FormulaR1C1 = "=SUMIF(C[-10],RC[-1],C[-3])"
Next i
Source : Excel vba sum unique items

Related

Assign a variable to cells to compare mutliple numbers

I have a data set where I need to compare the first number in each transect against each other.
For example, in the below data set I need to compare cells D2, D7, D12 and D17 and assign a value based on which one is the smallest number, the next smallest and so on. This will be used to assign the transect numbers in column A.
My issue is that the number of sections (in this example 4) and the number of transects (also 4 in this example) will vary. So the cells I need to compare will change.
I have written the code that calculates the number of transects, which is:
Dim tlength As Worksheet
Dim tb As Long *'tb=transect break*
Sub tlength_start_stop_coords()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")
Set tlength = ThisWorkbook.Worksheets("transect lengths") *' assigns the sheet to a variable
for efficient coding*
tb = 0 *'counter to calculate the number of transects*
j = 2 *'counter for row*
Lastrow = Lastrow + 1 *'add a row to last row so that the last row includes a blank line.*
*'the following for loop is used to calculate the number of transects*
For i = 2 To Lastrow
If tlength.Range("D" & i) = vbNullString Then
If tlength.Range("D" & i - 1) <> vbNullString Then
tb = tb + 1 *'updates the counter*
End If
End If
Next i
tbtotal = tb *'stores the total counter in variable tbtotal for later use*
I think I may need to use a loop. But I am stuck trying to figure out how to manage the unknown number of comparisons in changing cell locations.
The desired result is in the below screenshot of the expected outcome, with results in column A. To begin with, I only need to get the number for the first row of each transect. Once I have that, I can copy using xldown.
Expected outcome:
Another possible data set and outcome expected might be:
enter image description here
with an expected outcome of:
enter image description here
Worked for me using your second set of sample data:
Sub Tester()
Dim tlength As Worksheet, i As Long, tNum As Long, v, vPrev, arr
Dim col As New Collection, e, c As Range, rng As Range
Set tlength = ThisWorkbook.Worksheets("transect lengths")
'collect all the Section 1 Latitudes and row numbers
For i = 2 To tlength.Cells(Rows.Count, "B").End(xlUp).Row
If tlength.Cells(i, "B") = 1 Then
col.Add Array(i, tlength.Cells(i, "D").Value) 'store start row and first Latitude
End If
Next i
SortCollection col, 2 'sort collection by second element in each array
tNum = 0
'loop over the sorted collection and assign the order of the transects
For Each e In col
tNum = tNum + 1
Set c = tlength.Cells(e(0), "B")
'following assumes all transects have at least 2 sections...
tlength.Range(c, c.End(xlDown)).Offset(0, -1).Value = tNum
Next e
End Sub
'Sort a collection of 0-based arrays in ascending order by the n'th element of each array
'Adapted from https://stackoverflow.com/a/3588073/478884
Sub SortCollection(col As Collection, n As Long)
Dim i As Long, j As Long, vTemp As Variant
For i = 1 To col.Count - 1 'Two loops to bubble sort
For j = i + 1 To col.Count
If col(i)(n - 1) < col(j)(n - 1) Then 'change to > for ascending sort
vTemp = col(j) 'store the lesser item
col.Remove j 'remove the lesser item
col.Add Item:=vTemp, before:=i 're-add the lesser item before the greater Item
End If
Next j
Next i
End Sub

Excel formula or VBA required to resolve this case complicated

Dear Team Could you please help me on below case
In the excel file we have name and department with available resources
First table we have details and second table need to fill with number or just comments YES or NO.
I have tried with IF formula it will not be helpful because cells keep moving based on second table which changes daily
Formula which I have tried no useful
If(A2&b1=a12&b11,if(b2<0,"No","Yes"),"Match not found")
Could you please help me. VBA am new no idea how this case can be helpful
You may want to transform the first table from the cross-table layout to tabular (aka unpivot):
e.g. 1st column=name, 2nd column=department
then add 3rd column as combo: “name/department” (or any other delimiter in between)
| a1 | 1011 | a1/1011 | 1 |
| a1 | 1033 | a1/1033 | 3 |
etc.
In the second crosstable you could use vlookup/xlookup:
match criteria is the respective combo of the name to the left and the department on the column header (e.g. A12&”/“&”B11)
Match (vlookup) this against 3rd column from first table (in tabular layout) to get back then value (or “yes”) - this should work dynamically based on the value in the respective column and row headers (and not dependent on the position of the cells)
Use PowerQuery to unpivot and add 3rd column and replace the numbers with “yes” to create tabular version of first table
I asked a clarification question, but you were not interested in answering it.
Anyhow, I prepared an answer which should be fast enough, using arrays and a dictionary. It uses the ranges you show us in the picture. I wanted to configure it for using two sheets and automatically calculating the last row of each.
It assumes that in the first table there are unique names. In the second one may be as many names as you want, in any sorting order.
Please, test the next code and send some feedback:
Sub matchNames()
Dim sh As Worksheet, lastR As Long, dict As Object
Dim rngGlob As Range, rngRow As Range, arrGlob, arrSrc, i As Long, j As Long, arrYes, arrRet
Set sh = ActiveSheet
lastR = 7 ' if can be calculated, if two sheets will be used: sh.Range("A" & sh.rows.count).End(xlUp).row
Set rngGlob = sh.Range("A1:G" & lastR): arrGlob = rngGlob.Value2
arrSrc = sh.Range("B11:D11").Value2 'the array of numbers to be matched in the global array
arrRet = sh.Range("A12:D17").Value2 'the array of the range to return (Yes...)
'place the "Yes" string where the numbers exist in an array and load the dictinary:
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrGlob)
On Error Resume Next 'for the case of no any value on the processed row:
Set rngRow = rngGlob.rows(i).Offset(0, 1).Resize(1, rngGlob.Columns.count - 1).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngRow Is Nothing Then arrYes = getYes(rngGlob, rngRow, arrSrc)
dict(arrGlob(i, 1)) = IIf(IsArray(arrYes), arrYes, vbNullString) 'place the array containing Yes as Item
Erase arrYes
Next i
'place the dictionary arrays value in the array to be returned:
For i = 1 To UBound(arrRet)
arrYes = dict(arrRet(i, 1))
If UBound(arrYes) = UBound(arrSrc, 2) - 1 Then
For j = 0 To UBound(arrYes)
arrRet(i, j + 2) = arrYes(j)
Next j
Else
'place empty strings, to clean eventually older values whchid does not correspond, anymore
For j = 0 To UBound(arrSrc, 2) - 1: arrRet(i, j + 2) = "": Next j
End If
Next i
sh.Range("A12").Resize(UBound(arrRet), UBound(arrRet, 2)).Value2 = arrRet
End Sub
Function getYes(rngGlob As Range, rng As Range, arr) As Variant 'it returns the "Yes" array per name
Dim rngH As Range, arrY, i As Long, cel As Range, mtch
ReDim arrY(UBound(arr, 2) - 1)
Set rngH = rng.Offset(-(rng.row - 1))
For Each cel In rngH.cells
mtch = Application.match(cel.value, arr, 0)
If IsNumeric(mtch) Then
arrY(mtch - 1) = "Yes"
End If
Next cel
getYes = arrY
End Function

Map unique values to a specific Excel sheet

I'm wondering if its possible to create a VBA that map a random "numerical codes" from an excel Spreadsheet 2 (let's say column A) to a column B (Spreadsheet 1).
Some of the values on the spreadsheet 2 are repeated, I would like to build a unique correspondence (no repeated values from column A / Spreadsheet 2 to my column B / Spreadsheet 1)
Spreadsheet1:
Spreadsheet2
Desired output, column filled from Spreadsheet2 (Unique)values :
Is this possible?? feasible??
The following VBA code uses for loops to iterate through the list of values in Spreadsheet2 and only copy each value to Spreadsheet1 if the value has not occurred already in the list.
Option Explicit
Sub ListUniqueCodes()
Dim code As Long
Dim codes As Range
Dim i As Integer
Dim j As Integer
Dim last_row As Integer
Dim output_cell As Range
Dim unique_codes As New Collection 'You could also use a Scripting.Dictionary here as suggested by JvdV
'See https://stackoverflow.com/questions/18799590/avoid-duplicate-values-in-collection
'Store the length of the list of codes that is in Spreadsheet2:
last_row = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1").End(xlDown).Row
'Store the list of codes that is in Spreadsheet2:
Set codes = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1:A" & last_row)
'For each code...
For i = 1 To codes.Rows.Count
code = codes.Cells(i).Value2
'...if it does not equal zero...
If code <> 0 Then
'...and if it is not already in the collection unique_codes...
For j = 1 To unique_codes.Count
If unique_codes(j) = code Then Exit For
Next j
'...then add it to the collection unique_codes:
If j = (unique_codes.Count + 1) Then
unique_codes.Add code
End If
End If
Next i
Set output_cell = Workbooks("Spreadsheet1.xlsm").Sheets("Sheet1").Range("B2")
'Write out the unique codes in Spreadsheet1:
For i = 1 To unique_codes.Count
output_cell.Offset(i - 1, 0).Value2 = unique_codes(i)
Next i
End Sub

Loop through name list and if names exist in selection start after last name

I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output

Copy unique list based on criteria in another column vba excel

I want to use VBA to extract a unique, ordered list, subject to conditions in another column. So, I have two columns A, B.
A B
========
a FALSE
b FALSE
c TRUE
a TRUE
b FALSE
c TRUE
Should result in a list
C
==
a
c
I'm very, very new to VBA, so any help would be appreciated.
Oh, and the second list will be updated with every change to the first, so needs to be wiped to ensure there are no leftovers, if, for example, the second "a" is set to FALSE.
Here's a formula-only approach. Whether it's practical depends on your circumstances, but I have tested it with a sample of data similar to the one in the original question:
Insert a blank row at the top of the spreadsheet to serve as a header row.
Create a new formula column that will list the elements of column "A" only if column "B" is true. For example, place the following formula in cell D2, then copy it down: =IF(B2,A2,"").
Now you can apply the technique described in the second page linked by t.thielemans above.
One potential disadvantage of this approach is that the blank cells returned by the formula when column B is "FALSE" don't disappear--you'll still have a blank result in your filtered view.
I'll copy the reference here for convenience:
Getting unique values in Excel by using formulas only
What do you think of this?
Add the MS Scripting library first.
Option Explicit
Sub Test()
Dim oRange As Range
Dim dict As Dictionary
Dim vArray As Variant
Dim vItem As Variant
Dim sKey As String
Dim sValue As String
Dim iCompare_TRUE As Integer
Dim lCnt As Long
Dim lCnt_Rows As Long
Set dict = New Dictionary
Set oRange = ThisWorkbook.Sheets(1).Range("A1:B6")
For lCnt = 1 To oRange.Rows.Count
sKey = oRange(lCnt, 1)
sValue = oRange(lCnt, 2)
iCompare_TRUE = StrComp(sValue, "True")
If Not dict.exists(sKey) And iCompare_TRUE = 0 Then
With dict
.Add sKey, sValue
End With
End If
Next lCnt
ReDim vArray(1 To dict.Count)
vArray = dict.Keys
lCnt_Rows = UBound(vArray) + 1
Set oRange = ThisWorkbook.Sheets(1).Range(Cells(1, 3), Cells(lCnt_Rows, 3))
oRange.Value = Application.Transpose(vArray)
End Sub

Resources