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
Related
It is above my possibilities.
I know how to create Vba code with Vlookup or Hlookup for single comparision. However whatIi am trying is beyond my knowledge.
I need to compare 2 tables. 1st is requirements where 2nd is DB extract.
Both tables contains same "Action" column and other columns with Employer role as a header. Values from Action column for both tables are the same however in different order ( Those values need to act as primary key).
Columns with Employer role as a header - same header value for both tables - however columns in different order.
Amount of columns with Employer role as a header is not constants and it gets change every time I get this files. Those columns in extract are in different order than in requirements.
Amount of values from "Action" columns ( primary key) also not constants and change every time I receive files. So I cannot set specific range.
Example of Requirements table
Example of Extract table
Example of what is expected
New target worksheet need to be created where Comparison table will be created.
VBA to create Comparison table in newly created worksheet.
This table should have "Action" column + all columns with Employers role as header form requirements + all columns with Employers role as header form extract set in same order like columns in requirements + comparison table which compare values between Employers roles from Requirements and Extract and show values YES or NO
Try the next code, please. It will return in a newly created sheet (after the last existing). The new file is named "New Sheet". If it exists, it is cleared and reused:
Sub testMatchTables()
Dim sh As Worksheet, sh1 As Worksheet, shNew As Worksheet
Dim tbl1 As ListObject, tbl2 As ListObject, rightH As Long
Dim arrR, arrE, arrH1, arrH2, arrFin, i As Long, j As Long, k As Long
Dim first As Long, sec As Long, refFirst As Long, refSec As Long
Set sh = Set sh = Worksheets("Requirements")'use here the sheet keeping the first table
Set sh1 = Worksheets("Extract Table") 'use here your appropriate sheet
Set tbl1 = sh.ListObjects(1) 'use here your first table name (instead of 1)
Set tbl2 = sh1.ListObjects(1) 'use here your second table name (instead of 1)
arrR = tbl1.Range.value 'put the table range in an array
arrE = tbl2.Range.value 'put the table range in an array
'working with arrays will condiderably increase the processing speed
ReDim arrFin(1 To UBound(arrR), 1 To UBound(arrR, 2) * 3 + 2) 'redim the array to keep the processing result
'UBound is a property telling the number of array elements
arrH1 = Application.Index(arrR, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
arrH2 = Application.Index(arrE, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
'build the column headers:
For i = 1 To UBound(arrFin, 2)
If i <= UBound(arrH1) Then 'firstly the headers of the first table are filled in the final array
arrFin(1, i) = arrH1(i)
ElseIf refSec = 0 Then 'refSec is the column where a blanck column will exist
first = first + 1 'the code incrementes this variable to allow making empty only for the following row
If first = 1 Then
arrFin(1, i) = Empty: refFirst = i 'make the empty column between the two tables data and create a reference
'to be decreated from the already incremented i variable
Else
arrFin(1, i) = arrH1(i - refFirst) 'place each header column values
If i - refFirst = UBound(arrH1) Then refSec = i + 1 'when the code reaches the end of the first array
'it creates a reference for referencing the second time
End If
Else
sec = sec + 1 'the same philosophy as above, to create the second empty column
If sec = 1 Then
arrFin(1, i) = Empty 'create the empty column (for each processed row)
Else
arrFin(1, i) = arrH1(i - refSec) 'fill the header columns
End If
End If
Next
Dim C As Long, r As Long, eT As Long, T As Long
eT = UBound(arrR) 'mark the ending of the first array (where to be the first empty column)
T = UBound(arrR, 2) * 2 + 2 'mark the begining of the third final array part
'after the second empty column
For i = 2 To UBound(arrR) 'iterating between the first array rows
For j = 2 To UBound(arrE) 'iterating the second array rows
If arrR(i, 1) = arrE(j, 1) Then 'if the both arrays first column matches
arrFin(i, 1) = arrR(i, 1): arrFin(i, T + 1) = arrR(i, 1) 'put the Action values in the first area columns
arrFin(i, eT) = arrR(i, 1) 'put the Action values in the last area column
For C = 2 To UBound(arrR, 2) 'iterate between the array columns
rightH = Application.match(arrR(1, C), arrH2, 0) 'find the match of the first array header in the second one
arrFin(i, C) = arrR(i, C): arrFin(i, C + eT - 1) = arrE(j, rightH) 'place the matching header in the final array
If arrR(i, C) = arrE(j, rightH) Then
arrFin(i, T + C) = "TRUE" 'place 'TRUE' in case of matching
Else
arrFin(i, T + C) = "FALSE" 'place 'FALSE' in case of NOT matching
End If
Next C
End If
Next j
Next i
On Error Resume Next 'necessary to return an error if worksheet "New Sheet" does not exist
Set shNew = Worksheets("New Sheet")
If err.Number = 9 Then 'if it raises error number 9, this means that the sheet does not exist
err.Clear: On Error GoTo 0 'clear the error and make the code to return other errors, if any
Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.count)) 'set shNew as new inserted sheet
shNew.name = "New Sheet" 'name the newly inserted sheet
Else
shNew.cells.Clear: On Error GoTo 0 ' in case of sheet exists, it is clear and the code is made to return errors
End If
'set the range where the final array to drop its values:
With shNew.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.value = arrFin 'drop the array content
.EntireColumn.AutoFit 'AutoFit the involved columns
End With
End Sub
Please, test it and send some feedback.
Edited:
I commented the code as detailed I could. If still something unclear, please do not hesitate to ask for clarifications.
I have data that it's not in a consistent position in the cell, sometimes it has a semicolon, sometimes it is to the right or the left of the semicolon. The end result I'm looking is to have in column B all "students" (defined by not being teacher) and in Column C, all Teachers. If no student or teacher is found, then the corresponding cell should be blank.
Currently I'm doing a text to columns to separate both columns then using the following formulas to have the student and teacher separate:
=IF(SUMPRODUCT(--ISNUMBER(SEARCH({"Arts and Music","Math and Science"},A2)))>0,B2,C2)
=IF(SUMPRODUCT(--ISNUMBER(SEARCH("Teacher",A2)))>0,B2,C2)
I still have to do a manual Find and replace to remove the parenthesis and text and leave only the student/teacher name.
IS there any VBA macro that can help me to get from Column A to my expected result in columns B and C? Thank you.
You can use regular expressions to do this. See this post on how to enable them in excel.
Sub FindStrAndCopy()
Dim regEx As New RegExp
regEx.Pattern = "\s*(\w+)\s*\((.+)\)"
With Sheets(1):
Dim arr() As String
Dim val As String
Dim i As Integer, j As Integer
Dim person As String, teachOrSubject As String
Dim mat As Object
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row:
val = Cells(i, "A").Value
arr = Split(val, ";")
For j = 0 To UBound(arr):
Set mat = regEx.Execute(arr(j))
If mat.Count = 1 Then
person = mat(0).SubMatches(0)
teachOrSubject = mat(0).SubMatches(1)
If teachOrSubject = "Teacher" Then
Cells(i, "C").Value = person
Else
Cells(i, "B").Value = person
End If
End If
Next
Next
End With
End Sub
The macro splits the string on a semicolon and stores either 1 or 2 substrings in the 'arr' array. It then does a regular expression on each one. If the string inside the parenthesis is "Teacher" then the preceding person's name is stored in column "C" otherwise it's a student and the name is stored in column "B".
I create a button that read all the registers you have on column A
then put the students on column B
then put the Teacher on column C
Check that I used "(Teacher)" to know when a teacher is in the String
I used the sheet Called "Sheet1"
And I don't use the first row because is the header row.
If you have any question please contact me.
Private Sub CommandButton1_Click()
'---------------------------------Variables-----------------------------
Dim total, i, j As Integer
'--------------Counting the number of the register in column A----------
ThisWorkbook.Sheets("Sheet1").Range("XDM1").Formula = "=COUNTA(A:A)"
total = CInt(ThisWorkbook.Sheets("Sheet1").Range("XDM1").Value)
'---------------------Creating arrays to read the rows------------------
Dim rows(0 To 1000) As String
Dim columnsA() As String
'------------Searching into the rows to find teacher or student---------
For i = 2 To total
columnsA = Split(ThisWorkbook.Sheets("Sheet1").Range("A" & i).Value, ";")
first = LBound(columnsA)
last = UBound(columnsA)
lenghtOfArray = last - first
MsgBox lenghOfArray
For j = 0 To lenghtOfArray
If InStr(columnsA(j), "(Teacher)") > 0 Then
MsgBox columnsA(j)
ThisWorkbook.Sheets("Sheet1").Range("C" & i).Value = columnsA(j)
Else
ThisWorkbook.Sheets("Sheet1").Range("B" & i).Value = columnsA(j)
End If
Next j
Next i
'--------------------------------Finishing------------------------------
End Sub
I have an extremely large dataset with customer numbers and we cannot just use a =IF(E3=160248, "YES", "NO") to tag a particular customer number of 160248 with YES or NO. Instead, I would like to use VBA code to lookup Customer_Number in column E and return a YES or NO in the corresponding row in Column AG, called Incorporated_160248. I have not done an If then clause in VBA, so I have no idea where to start. Please note, each month the data set can change. One month it could be 4,000 entries and the next 3,500, so that has to be dynamic. Any thoughts?
Sub TagTryco()
Dim CN As Integer, result As String
CN = Range("E:E").Value
If CN = 160248 Then
result = "YES"
Else
result = "NO"
End If
Range("AG:AG").Value = result
End Sub
I get a Compile error: Wrong number of arguments or invalid property assignment.
This CODE Works now:
Sub TagTryco()
Dim listLength
listLength = Worksheets("ILS_Import").Cells(Rows.Count, "E").End(xlUp).Row - 1
Dim i As Integer
For i = 2 To listLength + 2
If Worksheets("ILS_Import").Range("E" & i) = 160248 Then
Worksheets("ILS_Import").Range("AG" & i) = "Yes"
Else
Worksheets("ILS_Import").Range("AG" & i) = "No"
End If
Next
End Sub
To know how many entries you have:
dim listLength
listlength = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row - 1 'I assumed column E, starting at row 2
You need to loop from row 2 to the row 2 + listLength, check the cell in column E, and check if it is equal to your number:
dim i as integer
for i = 2 to listLength + 2
If Range("E" & i) = 160248 Then
Range("AG" & i) = "Yes"
Else
Range("AG" & i) = "No"
End If
Next
If you wish to scan for different numbers you can adapt the code to use a value from a cell in which you enter that number, OR use an inputbox to enter the number you want to look for, or something else. This code was not tested.
If you want to use the column name you assigned instead of AG (which is safer) you can use something along the lines of:
= Range("Incorporated_160248")(i+1)
Instead, which gives the column with an offset of i. Should bring you to the right cell.
I am not familiar with using macro's, but I think that what I would like excel to perform is best handled with a macro. So I can use all the input you may have!
I have these headers;
ID Tag Pen Sex Weight Class Inside range
With 450 rows of data. Based on the distribution of the weight data, I have in two other columns (class and number) the number of rows I want to select within each class. The selected rows must have the value "Yes" in the column "Inside range".
I want to randomly select the rows, based on the number needed for each class, and copy these rows to a new sheet. It sums up to 30 rows in the new sheet.
I hope you have a suggestion how to complete this action!
can you try the following, you will need to add a reference to Microsoft Scripting Runtime library:
Const rowCount = 450
Public Sub copyRows()
Dim i As Integer
Dim j As Integer
Dim classes As Scripting.Dictionary
Dim source As Worksheet
Dim colNumber As Integer
Dim colClassName as Integer
Dim colInsideRange As Integer
Dim allSelected As Boolean
Dim randomRow as Integer
Dim sumRemaining as Integer
allSelected = False
Set source = Worksheets("YourWorksheetName")
colClassName = 6 'this is the column number where class names are entered. I am assuming 6
colNumber = 7 'this is the column number where number of rows to be selected are entered. I am assuming 7
colInsideRange = 8 'this is the column number where "Inside Range" values are entered. I am assuming 9
For i = 2 to rowCount + 1 'assuming you have a header row
classes(CStr(source.Cells(i, colClassName))) = CInt(source.cells(i, colNumber)
Next i
Do until allSelected
Randomize
randomRow = Int ((Rnd * 450) + 2) 'assuming you have a header row, + 1 if you don't
If classes(CStr(source.Cells(randomRow, colClassName))) = 0 Then
With classes
sumRemaining = 0
For j = 1 to .Count - 1
sumRemaining = sumRemaining + .Items(j)
If sumRemaining > 0 Then Exit For
Next j
allSelected = (sumRemaining = 0)
End With
Else
source.Cells(randomRow, colInsideRange) = "Yes"
classes(CStr(source.Cells(randomRow, colClassName))) = classes(CStr(source.Cells(randomRow, colClassName))) - 1
End If
Loop
'Enter your code to copy rows with "Inside Range" = "Yes"
End Sub
Sorry if there are some errors or typos, I wrote from my mobile phone.
I have a two dimensional table in Excel. eg.
outputproduct blending combination
**5 P1:0.6/P3:0.5**
2 P1:0.3/P2:0.7
4 P5:0.4/P2:0.7
7 P11:0.7/P7:0.4
Suppose the range of the table varies from B2:C6 (it can vary). I have to create a function, whose first job is to read this range( which would be a user defined input) and then stores the data into a 2 dimensional array such that I could use the data(integer) in the first column and the string in the second column, appropriately.
The first column is the resultant product index, while the second column is the blending products in the given ratio, which combine together to give the product in the first column.
Then there is another table:
product index current stock updated stock
**1** **10**
2 20
**3** **50**
4 15
**5** **100**
. .
. .
. .
I have to update the stock amount in this table after the data processing.
For example, on combination of product 1 with product 3 in the ratio of 6:5 (units), 1 unit of product 5 is produced. So, I have to update the amount of stock for each of the products in table 2.
Any suggestions, how to convert the range into a 2 dimensional array?
Public Function Blending_function( R1 as Range, R2 as Range)
' R2 is the range of table 2, where the updating is to be done
' R1 is first stored in to a 2 dimensional array, such that the data in the
' column 1 could be read, and the data in the column 2 could be read (of table 1).
' the integer in the column 1 of table 1 refers to the product index in table 2.
' P(i) stands for the ith product. In first row of table-1, P1 and P3 combine in the
' ratio of 6:5 to give P5. The current stock of each product is provide in table-2,
' whose range is R2(entire table 2).
' R1 is the range of table 1, from where the processing is to be done
End Function
The main hurdle for me is to convert the range R1 (Table-1) into a 2 dimensional array. And then look from that array, the index of the output product, and locate that product in table-2 for updating the stock level.
Here is an example on how to work with 2D array. The function will break up the blending combination and extract the values that you want so that you can use those.
Sub Sample()
Dim Rng1 As Range, Rng2 As Range
On Error Resume Next
Set Rng1 = Application.InputBox("Please select the Table1 Range", Type:=8)
On Error GoTo 0
If Rng1.Columns.Count <> 2 Then
MsgBox "Please select a range which is 2 columns wide"
Exit Sub
End If
On Error Resume Next
Set Rng2 = Application.InputBox("Please select the Table2 Range", Type:=8)
On Error GoTo 0
If Rng2.Columns.Count <> 3 Then
MsgBox "Please select a range which is 3 columns wide"
Exit Sub
End If
Blending_function Rng1, Rng2
End Sub
Public Function Blending_function(R1 As Range, R2 As Range)
Dim MyAr1 As Variant, MyAr2 As Variant
Dim i As Long
Dim blndCom As String, OutputPrd As String
Dim ArP1() As String, ArP2() As String, tmpAr() As String
MyAr1 = R1
For i = 2 To UBound(MyAr1, 1)
OutputPrd = MyAr1(i, 1)
blndCom = MyAr1(i, 2)
tmpAr = Split(blndCom, "/")
ArP1 = Split(tmpAr(0), ":")
ArP2 = Split(tmpAr(1), ":")
Debug.Print OutputPrd
Debug.Print Trim(ArP1(0))
Debug.Print ArP1(1)
Debug.Print ArP2(0)
Debug.Print ArP2(1)
Debug.Print "-------"
Next
End Function
SNAPSHOT
Once you have these values you can use .Find to search for the product index in the range R2 and then use .Offset to enter your formula.
I'm not sure if I understood the entire story, but this is what a function to return
a multidimensional array could look like:
Public Sub Main_Sub()
Dim vArray_R1() As Variant
Dim oRange As Range
Set oRange = ThisWorkbook.Sheets(1).Range("A1:B5")
vArray_R1 = Blending_function(oRange)
'You do the same for The second array.
set oRange = nothing
End Sub
Public Function Blending_function(R1 As Range)
Dim iRange_Cols As Integer
Dim iRange_Rows As Integer
iRange_Cols = R1.Columns.Count
iRange_Rows = R1.Rows.Count
'Set size of the array (an existing array would be cleared)
ReDim vArray(1 To iRange_Rows, 1 To iRange_Cols)
vArray = R1
Blending_function = vArray
End Function
A second option could be to declare the function to return a boolean and since arguments are standard sent byRef; you can declare the ranges and arrays in the main sub only, and convert them both at the same time in the function. I wouldn't choose for this option, because you wouldn't be able to re-use the function afterwards to convert other ranges into arrays.
Supplementary info:
This technique works both ways. You can afterwards define a range and do:
set oRange = vArray
This on the condition that the Range has the same size as the array.
row = 2
column = "B"
Do While Len(Range(column & row).Formula) > 0
' repeat until first empty cell in column 'column'(user input)
' read (column, row) and (column+1, row) value
Cells(row, column).Value
Cells(row, column+1).value
' store in Array
Loop