VBA- Need to create a function, which takes the range as input - vba

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

Related

finding the largest binary number from a range of cells

I have a data of some binary numbers in few range of cells, from A2 to A8, B2 to B8, and so on, till G column.
Now, I want to check the largest binary number from the above Rows and paste it to the cell, two row below the last used range. (i.e., Largest binary number from Row A to be paste in A10, and so on).
I am not finding any function which can find the value of binary numbers, and the code which I ran finds out the max number considering those as natural numbers.
Your help will be appreciated.
Thank You!
Okay first i made a function that converts binary to decimal and stored in a module. (You can store it wherever you want) This function handles any size binary
Function BinToDecConverter(BinaryString As String) As Variant
Dim i As Integer
For i = 0 To Len(BinaryString) - 1
BinToDecConverter = CDec(BinToDecConverter) + Val(Mid(BinaryString, Len(BinaryString) - i, 1)) * 2 ^ i
Next
End Function
Afterwards i made the sub that loops through all binarys on sheet1 (Might need to change this for your sheet)
Sub FindLargestBinary()
On Error Resume Next
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Application.ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Dim tempVal, tempRow As Integer
Dim iCoulmn, iRow As Integer
For iCoulmn = 1 To 7 'Run from A to G
tempRow = 2
tempVal = 0
For iRow = 2 To 8 'Run from row 2 to 8
If BinToDecConverter(ws.Cells(iRow, iCoulmn).Value) > tempVal Then tempVal = BinToDecConverter(ws.Cells(iRow, iCoulmn).Value): tempRow = iRow ' Check if current binary i higher then any previous
Next iRow
ws.Cells(iRow + 1, iCoulmn).Value = ws.Cells(tempRow, iCoulmn).Value 'Print highest binary
Next iCoulmn
End Sub
Hope this helps you out..
You can use the excel function Bin2Dec to change them into decimal
Function MaxBin(r as range)
Dim curmax as long
Dim s as range
For each s in r
If Application.WorksheetFunction.Bin2Dec(s.Text) > curmax Then curmax = Application.WorksheetFunction.Bin2Dec(s.Text)
Next s
MaxBin = curmax
End Function
Assuming your binary values are text strings this formula converts the values to numbers, finds the MAX and then converts back to a text string
=TEXT(MAX(A2:A8+0),"00000")
confirmed with CTRL+SHIFT+ENTER
or you can use this version which finds the max using AGGREGATE function and doesn't require "array entry"
=DEC2BIN(AGGREGATE(14,6,BIN2DEC(A2:A8+0),1))

Looping through columns to get column numbers based on headers

I have a template with a set number of columns (170) and title headers (row 1 cell name's). This is always the same, until users add columns in between (they're instructed not to change headers). The idea is to make it tamperproof as far as the adding of columns is involved.
I'd like to make variables to hold some of the headers (with the capacity to hold all) and check these with the template to find out the column number (in a loop I reckon). It's probably wisest to make a function to call upon it?
Dim ColHeader1Str as string 'literal row 1, column 1 value (which is always
'the same string and position in the template)
Dim iColHeader1 as integer 'holds the (to be set) value of the column number
Set ColHeader1Str = "ColHeader1"
Now I'd like a loop where it loops trough all the columns (last column = 200) and checks to see what the column number is that matches the ColHeader1Str and store this in the iColHeader1
So something like:
Function find_columnNmbr
Dim i As Integer
For i = 1 To 200 Step 1
If 'ColHeader1Str matches actual column header name
'set found integer as iColHeader1 and so forth
Exit For
End If
Next
End Function`
I know I'm missing a few steps and I'm hoping you guys can help me out.
Update: The template has set column headers. When users interact with it a result could be that columns shift position, or they add more. I have a workbook that needs to load data out of the user's altered template.
I.E. The template has columns 1, 2, 3, 4 and the names are column1, column 2 etc. A user ads a random column so now there are 5. The loop needs to loop through the names of the column headers and identify the column number of the original template columns 1, 2 etc based on a string variable with the original names, which I've hard coded beforehand. These are public constants.
What function LookForHeaders do: input a string, then search for the string in usersheet.range(1:1). If it is found, return the column number of that cell, otherwise it returns 0.
Private Function LookForHeaders(ByVal headerName As String) As Long
Dim rng As Range
Dim userSheet As WorkSheet
Set userSheet = 'userSheet here'
On Error GoTo NotFound
LookForHeaders = userSheet.Range("1:1").Find(headerName).Column
Exit Function
NotFound:
LookForHeaders = 0
End Function
Private Sub Test()
Dim rng As Range
Dim template As WorkSheet
Set template = 'template here'
For Each rng In template.Range(Cells(1,1), Cells(1,200))
iColHeader1 = LookForHeaders(rng.Value)
'Do something with iColHeader1
Next rng
End Sub
Not sure what your looking for but here is example
Option Explicit
Public Sub Example()
Dim LastCol As Long
Dim i As Long
LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
For i = 1 To LastCol
If Cells(i) = "Name" Then
Debug.Print Cells(i).Address
End If
Next
End Sub

Match columns with COUNTIF by rows

I am trying to create a custom function to evaluate some data. The data consists of a few samples (in columns) taken from a living organism and the bacteria + their magnitude (in rows). I know which bacteria are unique (only appear in 1 sample) but I want to know how many unique bacteria are in each sample.
To know which bacteria are unique I use =COUNTIF(A:A,">"&0) on each row and if returns a 1 then it is unique.
Ideally I was thinking of something along the lines of:
Function Custom(sampleRange, occurringBacteria) As Integer
Dim bacteriaUniqueToSample as Integer: bacteriaUniqueToSample = 0
For Each sampleRange And occurringBacteria
If sampleRange > 0 And occurringBacteria = 1
Then bacteriaUniqueToSample = bacteriaUniqueToSample + 1
Next
Custom = bacteriaUniqueToSample
End Function
Of course, that is not possible.
Example:
Enter this in cell B7 and copy across till D7
=COUNTIFS(B$2:B$5,">"&0,$E$2:$E$5,"Unique")
A User Defined Function (aka UDF) could be written for this. While your sample layout has a correlation between the cell with the function and the cell holding the Sample1, Sample2, etc labels, to be more universal you will need to provide a wider worksheet relationship.
Function uniq_bacts_by_sampl(rSample As Range, rOccurringBacteria As Range)
Dim cnt As Long, rw As Long, rng As Range
For rw = 1 To rOccurringBacteria.Rows.Count
Set rng = Application.Index(rOccurringBacteria, rw, 0)
If Application.CountIf(rng, ">" & 0) = 1 And _
CBool(Cells(rng.Row, rSample.Column).Value2) Then
cnt = cnt + 1
End If
Set rng = Nothing
Next rw
uniq_bacts_by_sampl = cnt
End Function
The UDF is put to use just as any other native worksheet function.
Syntax:        =uniq_bacts_by_sampl(<cell with label criteria>, <data range>)
       
The formula in the above sample image's B7 is,
=uniq_bacts_by_sampl(B$1, $B2:$D5)
Fill right as necessary.

Selecting one column from each row in a table

I have a table structured (Table Name: Table2) like below:
Using VBA, I want to select ONLY a single column value of the current row by iterating over each row.
Here is the code and I wrote:
Function findColumnValue(strColCombIdent As String, strColumnName As String) As String
On Error Resume Next
Dim strRetResult As String
Dim wsMapMasterRefSheet As Worksheet
'Referes to the table Table2.
Dim loMapMaster As ListObject
Set wsMapMasterRefSheet = ThisWorkbook.Worksheets("Sheet3")
Set loMapMaster = wsMapMasterRefSheet.ListObjects("Table2")
'All rows of the table Table2
Dim rAllRows As Range
Set rAllRows = loMapMaster.DataBodyRange
'Holds one row from the databody range for processing.
Dim rCurrRow As Range
'Process data
Dim strTemp As String
For Each rCurrRow In rAllRows
strTemp = rCurrRow.Columns(2)
Debug.Print strTemp
Next rCurrRow
findColumnValue = strRetResult
End Function
I was hoping to get results like below (ONLY the value of the column 2):
1.5
1.5
1.8
4
3
3
1
2
10
12
5
7
Instead I end up with something like this (All values from column#2 onwards, for each processing row.)
1.5
0.045150462962963
1.5
4.52083333333333E-02
1.8
4.72685185185185E-02
4
0.168090277777778
3
3.1
3
8.47800925925926E-02
1
4.16666666666667E-02
2
8.33449074074074E-02
10
10.1.1.1
12
1.3.4.5
5
0.212511574074074
7
8.54166666666667E-02
Using
strTemp = rCurrRow.Columns(1, 2)
instead of
strTemp = rCurrRow.Columns(2)
Causes runtime error 1004
Since each iteration points to a range object in the For loop; I was thinking using
rCurrRow.Columns(2)
will point to current Row's column#2 and hence print out only the column's value.
Is my logic misplaced?
One additional question:
Why does the MSDN Excel Reference guide describes Columns as a Property; where as clearly the "Columns" usage clearly takes parameters
Here is the link I referred:
http://msdn.microsoft.com/en-us/library/office/ff197454(v=office.15).aspx
Either specify you want to iterate rows:
For Each rCurrRow In rAllRows.Rows
or only look at the ListRows in the first place:
Function findColumnValue(strColCombIdent As String, strColumnName As String) As String
On Error Resume Next
Dim strRetResult As String
Dim wsMapMasterRefSheet As Worksheet
'Referes to the table Table2.
Dim loMapMaster As ListObject
Set wsMapMasterRefSheet = ThisWorkbook.Worksheets("Sheet3")
Set loMapMaster = wsMapMasterRefSheet.ListObjects("Table2")
'All rows of the table Table2
Dim rAllRows As ListRows
Set rAllRows = loMapMaster.ListRows
'Holds one row from the databody range for processing.
Dim rCurrRow As ListRow
'Process data
Dim strTemp As String
For Each rCurrRow In rAllRows
strTemp = rCurrRow.Range(, 2)
Debug.Print strTemp
Next rCurrRow
findColumnValue = strRetResult
End Function
You can call your variable rCurrRow all you want; VBA still won't know that you mean for it to contain an entire row of range rAllRows. It just assumes that rCurrRow represents one cell, such that For Each rCurrRow In rAllRows means "for each individual cell in this range".
What you need to do is limit the range being looped through. This should work; not tested.
For Each rCurrRow In rAllRows.Columns(2)
strTemp = rCurrRow
Debug.Print strTemp
Next rCurrRow
In fact I wouldn't call that variable rCurrRow at all; if you're going to use it in this way, call it e.g. cell instead.
EDIT: now that you have clarified your question in a comment below, you could do this:
For i = 1 To rAllRows.Rows.Count
Set rCurrRow = rAllRows.Rows(i)
strTemp = rCurrRow.Cells(1,2)
Debug.Print strTemp
Next i
But even better and faster would be to load the entire range to a two-dimensional Variant array at once, and loop over that array — much faster than looping over many cells.
Dim v As Variant
v = rAllRows ' load entire range to a 2D array
For i = 1 To UBound(v,1)
strTemp = v(i,2)
Debug.Print strTemp
Next i
Why does the MSDN Excel Reference guide describes Columns as a Property; where as clearly the "Columns" usage clearly takes parameters
Both methods and properties can take parameters. The distinction is more or less as follows:
Properties are things that you can get (like a range's Address, which takes no parameter, or subrange such as Column or Row or Cells, which do) and/or set (like a range's .Interior.Color, or .Hidden status). They are usually nouns.
Methods are things that do something to/with the range, and as such are usually verbs. Like .Select (takes no parameters) or .Copy (takes one parameter) or even .Speak.

return single values for multiple records

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