Related
If i have this code is there a simple way to add item1 to the beginning of the array and item2 to the end of the array in VBA?
The below code currently runs.
Dim nameArray as variant
Dim k as integer
Dim item1 as string
Dim item2 as string
k = 1
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
For Each i In nameArray
newcol = baseclmn + k
tblComp.ListColumns.Add(newcol).Name = i
k = k + 1
Next I
Thanks for any help you can offer
You could start off with a larger array and replace the first and last items.
Dim nameArray as variant
nameArray = Range(Cells(1, 3), Cells(6, 3)).Value
nameArray(LBound(nameArray), 1) = "Item1"
nameArray(UBound(nameArray), 1) = "Item2"
If you want to expand the array, perhaps something like this:
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
Dim newArray
ReDim newArray(1 to Ubound(nameArray, 1) + 2, 1 to Ubound(nameArray, 2)) 'add two rows
newArray(1, 1) = "item1"
newArray(Ubound(newArray, 1), 1) = "item2"
Dim i As Long
For i = LBound(nameArray, 1) To Ubound(nameArray, 1)
newArray(i + 1, 1) = nameArray(i, 1)
Next
Explanation:
nameArray is a 2-dimensional array, where the first dimension corresponds to rows and the second to columns. Note that this array is one-based, i.e. the first index is 1 and not 0.
The code uses ReDim to create a new array, containing
Two more rows than nameArray
The same number of columns as nameArray.
Then it adds the first and last items:
newArray(1, 1) = "item1": 1, 1 corresponds to the first row, first column.
newArray(Ubound(newArray, 1), 1) = "item2": Ubound(newArray, 1) corresponds to the last row, and 1 again corresponds to the first column.
Finally it uses a loop to read the items from nameArray into the middle of newArray.
Further helpful reading includes Arrays and Ranges in VBA.
You can enlarge (and/or restructure) the existing (vertical) nameArray in one go
via an undocumented feature of Application.Index()
using either the new Sequence() function (available since MS 365!) or a workaround via row evaluation (commented out in comment)
to pass a whole array(!) of row numbers (rowArr) as argument (instead of a single row index):
newArray = Application.Index(nameArray, rowArr, 1)
where rowArr is a vertical array of sequential row numbers reflecting the currently existing indices, and 1 the unchanged column index.
Sub TopBottomAdditions()
'0. define 1-based 2-dim data field
Dim nameArray
nameArray = Sheet1.Range(Cells(2, 3), Cells(5, 3)).Value 'i.e. data field of cells C2:C5
'1a create a sequence (array) ranging from 0 to elements count plus +1 (2 new elems)
Dim rowArr ' {0,1,2,..n,n+1}
rowArr = WorksheetFunction.Sequence(UBound(nameArray) + 2, 1, 0)
''>workaround if you don't dispose of version MS 365
' rowArr = Evaluate("row(1:" & UBound(nameArray) + 2 & ")-1")
'1b keep existing values in rows 1..n and add top+bottom element
'note: index 0 fetches element of existing index 1, n+1 gets a temporary error value
Dim newArray
newArray = Application.Index(nameArray, rowArr, 1)
'1c insert new top & bottom values
newArray(1, 1) = "Top value" ' overwrites New elem no 1
newArray(UBound(newArray), 1) = "Bottom value" ' writes New last elem
End Sub
Syntax of Sequence()
=SEQUENCE(rows,[columns],[start],[step])
I have a worksheet, and I want to be able to go through one column (O) to find the different values, then go to another column (U) and count whether the sting is paper or electronic. Then, I want to be able to take the total of paper/electronic stings from U with each instance in O (source) and put it into the following table on a different sheet with VBA.
Due to the sensitivity of the data, I quickly made a table with basically what I mean. Pretend A is O and B is U.
And I want the output in this table, or if there is a better way to present the data:
I've tried making a pivot table, but it simply counts each instance of the paper/electronic string in the sheet, and I need to cross reference the values in O with U.
Here is the formula what you desire. Remember that we need to change source value and Fillining medium value in each row. you can see from the image that in formula for Source A values are "A" and "Paper" for paper count and "A" and "Electronic" for electronic count. the formulas for Source A are written at the bottom of the table and formula for Source C you can See from formula Bar. This is to show you the change you need to make in formula for each source.
if you have excel 365 you can just use the unique/countifs function. For simplicity I assume your data is in col A & B
To get the unique values (source) col E:
=UNIQUE(A:A)
To count (manually add "paper" as header in col F:
=COUNTIFS(A:A;E2;B:B;$F$1)
Do the same for the other values.
EDIT:
Anything can be done in code:
Option Explicit
Sub DictUniqueFinal()
Dim arr, arr2, arrH, j As Long, dict As Object, id As String
'setup some arrays
arrH = Split("Source, Paper, Electronic", ",")
arr = Sheet1.Range("A1").CurrentRegion.Offset(1, 0).Value2 'load source without headers
ReDim arr2(1 To UBound(arr), 1 To 3)
'setup the dict
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
For j = 1 To UBound(arr) - 1 'traverse source
id = arr(j, 1)
If Not dict.Exists(id) Then 'create key
If arr(j, 2) = "paper" Then
dict.Add id, 1 & "," & 0
Else
dict.Add id, 0 & "," & 1
End If
Else 'update key
If arr(j, 2) = "paper" Then
dict(id) = Split(dict(id), ",")(0) + 1 & "," & Split(dict(id), ",")(1)
Else
dict(id) = Split(dict(id), ",")(0) & "," & Split(dict(id), ",")(1) + 1
End If
End If
Next j
'build final array
ReDim arr2(0 To dict.Count - 1, 1 To 3)
For j = 0 To dict.Count - 1
arr2(j, 1) = dict.Keys()(j)
arr2(j, 2) = Split(dict.Items()(j), ",")(0)
arr2(j, 3) = Split(dict.Items()(j), ",")(1)
Next j
'dump to sheet
With Sheet2
.Range(.Cells(1, 1), .Cells(1, UBound(arrH) + 1)).Value2 = arrH
.Range(.Cells(2, 1), .Cells(UBound(arr2) + 2, UBound(arr2, 2))).Value2 = arr2
End With
End Sub
It's a bit long and I had to hard code, but I found a solution, thanks to #AnmolKumar I looked in to Countif and found this:
ws2.Range("F15").Value2 = Excel.WorksheetFunction.CountIfs, _
(ws3.Range("O1:O" & lstRow2), "A", ws3.Range("U1:U" & lstRow2), "Paper")
I'll just have to do it for each different section
I have two tables in Excel, one with categories and listings, and another with points based on the category and listing threshold. It goes as follows:
Categories table:
ID
CATEGORY
LISTINGS
Points
001
A
56
002
C
120
003
A
4
004
B
98
Points table:
Category
tier1
tier2
tier3
A
Tier 1
Tier 2
Tier 3
Range
1-30
31-90
91-
Points
10
20
30
B
Tier 1
Tier 2
Tier 3
Range
1-25
26-100
101-
Points
10
20
30
C
Tier 1
Tier 2
Tier 3
Range
1-40
41-80
81-
Points
10
20
30
I started with an INDEX MATCH formula pointing at the points:
=INDEX(Points!A1:D11, MATCH(Categories!B2, Points!A1:A11, 0)+2)
--> the +2 is to get the points directly
I also though of evaluating the thresholds with this formula:
=IF(Categories!C2 >= NUMBERVALUE(LEFT(Points!D3, FIND("-",Points!D3)-1)),Points!D4, IF(Categories!C2 >=NUMBERVALUE(LEFT(Points!C3, FIND("-",Points!C3)-1)),Points!C4, Points!B4))
I thought that the else if the if would make it faster.
Could someone help me populate the Points column in the Categories table? VBA code is also acceptable. The tables are in different sheets.
José, your original Match formula is the right starting place. It locates the particular sub-table to do a further lookup on. But in order to make this formula a whole lot simpler, can we change the ranges (1-30, 31-90, 91-) to have just their starting points (1, 31, 91)? If we do that simple change then we can use the approximate lookup feature of HLookup to easily and compactly specify the Lookup:
=HLookup($C2,Offset(Points!$A$1,Match($B2,Points!$A:$A,0),1,2,3),2,True)
In the middle of this formula you can see your original Match function to locate the correct sub-table based on the category. We need to feed that start point to OFFSET() to create a table range useful to the HLookup. Offset takes an anchor cell reference (top left of the Points table), number of rows to count down from there (result of the Match), number of columns to the right (1), the number of rows in the range (2), and the number of columns in the range (3).
The Hlookup is just like a VLookup, but for tables arranged left-to-right not top-to-bottom. The True as the last parameter is very important as it tells HLookup to use the range lookup instead of an exact match.
A slightly verbose formula which takes the data as originally formatted (using Excel 365 Let):
=LET(ranges,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0),0),
leftRanges,VALUE(LEFT(ranges,FIND("-",ranges)-1)),
points,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0)+1,0),
INDEX(points,MATCH(C2,leftRanges)))
As it's urgent this is what I got but I cannot continue before tomorrow. Assuming you can at least put the tiers next to the category (A on same line as tiers) this will get you the first tier. You just need to copy the whole formula in the "nextCol", with minor modifications to get the next tiers.
if you really cannot change the source you need to add an additional offset in the first match.
=IF(AND(D1>NUMBERVALUE(LEFT(INDIRECT("B"&MATCH(E1,A:A,0)),FIND("-",INDIRECT("B"&MATCH(E1,A:A,0)))-1)),D1<NUMBERVALUE(RIGHT(INDIRECT("B"&MATCH(E1,A:A,0)),2))),INDEX(B:D,MATCH(E1,A:A,0)+1,1),"nextCol")
Option Explicit
Sub Score()
Dim wsP As Worksheet, wsC As Worksheet, dict
Dim iLastRow As Long, r As Long, i As Long, j As Integer
Dim sCat As String, iListing As Integer
Dim data, ar
Set wsP = Sheets("Points")
Set wsC = Sheets("Categories")
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row
data = wsC.Range("A1:D" & iLastRow).Value2
' category to row lookup
For i = 1 To UBound(data)
If data(i, 1) = "Range" Then
dict.Add Trim(data(i - 1, 1)), i ' range
End If
Next
' scan points
iLastRow = wsP.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To iLastRow
sCat = Trim(wsP.Cells(r, "B"))
iListing = wsP.Cells(r, "C")
If dict.exists(sCat) Then
i = dict(sCat)
For j = 4 To 2 Step -1
ar = Split(data(i, j), "-") ' lower-upper limit
If iListing >= ar(0) Then ' check lower limit
' update points
wsP.Cells(r, "D") = data(i + 1, j) ' points
Exit For
End If
Next
Else
MsgBox "No match '" & sCat & "'", vbCritical, "ERROR row " & r
End If
Next
MsgBox "done"
End Sub
Please, try the next code. It uses arrays and should be very fast, working only in memory. Please use your sheets when setting shC and shP as your real sheets. I only use the active sheet and the next one for testing reason:
Sub GetPoints()
Dim shC As Worksheet, shP As Worksheet, lastRC As Long, lastRP As Long, arrBC, arrP, arrPP, arrFin
Dim i As Long, j As Long, p As Long, k As Long
Set shC = ActiveSheet 'use here your Categories sheet
Set shP = shC.Next 'use here your Points sheet
lastRC = shC.Range("A" & shC.rows.count).End(xlUp).row
lastRP = shP.Range("A" & shP.rows.count).End(xlUp).row
arrBC = shC.Range("B2:C" & lastRC).Value 'put the range B:C in an array
arrP = shP.Range("A2:D" & lastRP).Value 'put all the range in an array
ReDim arrFin(1 To UBound(arrBC), 1 To 1) 'redim the array to keep processed values
For i = 1 To UBound(arrBC) 'iterate between Categ array elements:
For j = 1 To UBound(arrP) 'iterate between Points array elements:
If arrP(j, 1) = arrBC(i, 1) Then 'if Category is found:
For p = 2 To 4 'iterate between the next array row elements
arrPP = Split(arrP(j + 1, p), "-") 'split the element by "-" to determine the interval
If arrPP(1) <> "" Then 'for the tier3 case:
If arrBC(i, 2) >= CLng(arrPP(0)) And arrBC(i, 2) <= CLng(arrPP(1)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
Else 'for the tier1 and tier2 cases:
If arrBC(i, 2) >= CLng(arrPP(0)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
End If
Next p
End If
Next j
Next i
'drop the final array result at once:
shC.Range("D2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub
I want to write excel formula that will sum the values based on a match of the rows. The cells to be matched can occur multiple times and basing on the Mapping legend they should return the sum of values.
In the yellow cells I am trying to calculate sum of values in range B9:B21 based on a match of the names in G3:G8 according to Mapping legend to Item1, then Item2 and Item 3.
I got already answer on how to sum the values if array to be summed is the same as Mapping legend. But now my array to be summed in extended and SUMPRODUCT formula does not work anymore:
Is there a solution to that?
This needs improving but is a starter user defined function that can be used in the sheet.
function GetSum
arg1 item String The item to match against e.g. Item2
arg2 sourceData Range The data range to sum over according to item
arg3 lookup Range The data range containing the mapping (2 columns wide)
Public Function GetSum(ByVal item As String, sourceData As Range, lookup As Range) As Variant
If lookup.Columns.Count <> 2 Then GetSum = CVErr(xlErrNA)
Dim lookupDict As Object, arr(), arr2(), i As Long, finalValue As Double
Set lookupDict = CreateObject("Scripting.Dictionary")
If lookup.Cells.Count = 1 Then
ReDim arr(1, 1)
arr(1, 1) = lookup.Value
Else
arr = lookup.Value
End If
If sourceData.Cells.Count = 1 Then
ReDim arr2(1, 1)
arr2(1, 1) = sourceData.Value
Else
arr2 = sourceData.Value
End If
For i = LBound(arr, 1) To UBound(arr, 1)
lookupDict(arr(i, 2)) = arr(i, 1)
Next i
For i = LBound(arr2, 1) To UBound(arr2, 1)
If lookupDict.exists(arr2(i, 1)) Then
If lookupDict(arr2(i, 1)) = item Then
finalValue = finalValue + arr2(i, 2)
End If
End If
Next i
GetSum = finalValue
End Function
Data:
Fix your formula :
=SUMPRODUCT(--(NOT(ISERROR(MATCH(B11:B20,F6:F9,0)))),C11:C20)
As in the picture (can't change excel language sosad) :
As a general guideline for this an future projects, I would recommend as it's been said to use a helper column to tag your items and simplify the formula greatly :
Hi everyone, by using an array formulas to calculate (in the above example):
Count unique customers that had purchased only less than 5 units of only product 1 which area code match only with the adjacent D cells
I Use the following array formula to be in E11:
=SUM(IF(FREQUENCY(IF($G$2:$G$7=D11,
IF($I$2:$I$7="Product 1",IF($J$2:$J$7<5,IF($E$2:$E$7<>"",
MATCH($E$2:$E$7,$E$2:$E$7,0))))),ROW($E$2:$E$7)-ROW(G2)+1),1))
this formula doing great, at the same time when using it thru very huge database containing tons of rows and columns, excel takes a bout 3 minutes to calculate only one cell which is terrible to continue like that
is there any way to convert this array formula to regular one ... any help will be appreciated to the maximum ... Thanks in advance
Sorry for the late answer.
I created an UDF which is focused on doing the calculation several times without running the whole range multiple times.
Public Function getCounts(AreaStr As Variant, AreaRng As Range, CustomerRng As Range, ProductRng As Range, SalesRng As Range, Optional ProductName As String = "Product 1", Optional lessThan As Double = 5) As Variant
'make sure AreaStr is an array
If TypeOf AreaStr Is Range Then AreaStr = AreaStr.Value2
If Not IsArray(AreaStr) Then
AreaStr = Array(AreaStr)
ReDim Preserve AreaStr(1 To 1)
End If
'shorten the range (this way you can use whole columns)
If SalesRng(SalesRng.Cells.Count).Formula = "" Then Set SalesRng = SalesRng.Parent.Range(SalesRng.Cells(1), SalesRng(SalesRng.Cells.Count).End(xlUp))
'make sure all ranges have the same size
Set AreaRng = AreaRng.Resize(SalesRng.Rows.Count)
Set CustomerRng = CustomerRng.Resize(SalesRng.Rows.Count)
Set ProductRng = ProductRng.Resize(SalesRng.Rows.Count)
'Load values in variables to increase speed
Dim SalesValues As Variant, UserValues As Variant, ProductValues As Variant
SalesValues = AreaRng
UserValues = CustomerRng
ProductValues = ProductRng
'create temporary arrays to hold the values
Dim buffer() As Variant, expList() As Variant
ReDim buffer(1 To UBound(UserValues))
ReDim expList(1 To UBound(AreaStr), 1 To 1)
Dim i As Long, j As Double, k As Long
For i = 1 To UBound(AreaStr)
expList(i, 1) = buffer
Next
buffer = Array(buffer, buffer)
buffer(0)(1) = 0
For i = 1 To UBound(UserValues)
If ProductValues(i, 1) = ProductName Then 'this customer purchased our product
j = Application.IfError(Application.Match(UserValues(i, 1), buffer(0), 0), 0)
If j = 0 Then 'first time this customer in this calculation
j = i
buffer(0)(j) = UserValues(i, 1) 'remember the customer name (to not calculate him again later)
If Application.SumIfs(SalesRng, CustomerRng, UserValues(i, 1), ProductRng, ProductName) < lessThan Then
buffer(1)(j) = 1 'customer got less than "lessThan" -> remember that
End If
End If
If buffer(1)(j) = 1 Then 'check if we need to count the customer
k = Application.IfError(Application.Match(SalesValues(i, 1), AreaStr, 0), 0) 'check if the area is one of the areas we are looking for
If k Then expList(k, 1)(j) = 1 'it is -> set 1 for this customer/area combo
End If
End If
Next
For i = 1 To UBound(AreaStr) 'sum each area
expList(i, 1) = Application.Sum(expList(i, 1))
Next
getCounts = expList 'output array
End Function
I assume that you will be able to include it as an UDF without my help.
In the sheet you would use (for your example) E11:E16
=getCounts(D11:D15,G2:G7,E2:E7,I2:I7,J2:J7)
simply select the range of E11:E16 and enter the formula, then confirm it with CSE.
you also could use only =getCounts(D11,$G$2:$G$7,$E$2:$E$7,$I$2:$I$7,$J$2:$J$7) at E11 and then copy down... but that would be pretty slow.
The trick is, that we calculate the sum of the set for every customer, which at least bought it one time. Then we store 1 if it is less then your criteria. This goes for the general array. Every area you are looking for, will get its own array too. Here we also store the 1 at the same pos. As every costomer only gets calculated one time, having him multiple times doesn't matter.
the formula simply will be used like this:
getCounts(AreaStr,AreaRng,CustomerRng,ProductRng,SalesRng,[ProductName],[lessThan])
AreaStr: the area code you are looking for. should be an array of multiple cells to make the udf worth using it
AreaRng: the range where the area names are stored
CustomerRng: the range where the customer names are stored
ProductRng: the range where the product names are stored
SalesRng: the range where the sale counts are stored
ProductName (optional): the product you are looking for. Will be "Product 1" if omited
lessThan (optional): the trigger point for the sum of products. Will be 5 if omited
Most parts should be self explaining, but if you still have any questions, just ask ;)
OK, I am not sure of I understood all of the conditions and accumulation, but here is a VBA function that I think should do it.
First, open VBA from the Excel Developer menu. Then in VBA, create a new module from the Insert menu (just let it be Module1). Then paste the following 2 functions into the VBA module.
Public Function AreaUniqueCustomersLessThan(ReportAreaRange, AreaRange, ProductRange, SalesRange, CustomerRange)
On Error GoTo Err1
Dim RptAreas() As Variant
Dim Areas() As Variant, Products() As Variant, Sales() As Variant, Customers As Variant
RptAreas = ArrayFromRange(ReportAreaRange)
Areas = ArrayFromRange(AreaRange)
Products = ArrayFromRange(ProductRange)
Sales = ArrayFromRange(SalesRange)
Customers = ArrayFromRange(CustomerRange)
Dim r As Long, s As Long 'report and source rows indexes
Dim mxr As Long, mxs As Long
mxr = UBound(RptAreas, 1)
mxs = UBound(Areas, 1)
'encode the ReportAreasList into accumulation array indexes
Dim AreaCustomers() As Collection
Dim i As Long, j As Long
Dim colAreas As New Collection
ReDim AreaCustomers(1 To mxr)
For r = 1 To mxr
On Error Resume Next
'Do we have the area already?
j = colAreas(RptAreas(r, 1))
If Err.Number <> 0 Then
'Add a new area to the collection and array
i = i + 1
colAreas.Add i, RptAreas(r, 1)
Set AreaCustomers(i) = New Collection
j = i
End If
Next r
'now scan the source rows, accumulating distinct customers
' for any ReportAreas
For s = 1 To mxs
'is this row's Arera in the report Area list?
i = 0
On Error Resume Next
i = colAreas(Areas(s, 1))
On Error GoTo Err1
If i > 0 Then
'this is a report Area code, so check the conditions
If Products(s, 1) = "Product 1" Then
If Sales(s, 1) < 5 Then
On Error Resume Next 'just ignore any duplicate errors
AreaCustomers(i).Add Customers(s, 1), Customers(s, 1)
On Error GoTo Err1
End If
End If
End If
Next s
'finally, return to the report area codes, returning the distinct count
' of customers
Dim count() As Variant
ReDim count(1 To mxr, 1 To 1)
For r = 1 To mxr
count(r, 1) = AreaCustomers(colAreas(RptAreas(r, 1))).count
Next r
AreaUniqueCustomersLessThan = count ' "foo"
Exit Function
Err1:
AreaUniqueCustomersLessThan = "%ERR(" & Str(Err.Number) & ")%" & Err.Description
Exit Function
Resume
End Function
'handle all of the cases, checking and conversions to convert
' a variant range into an array of Variant(1 to n, 1 to 1)
' (we do this because it makes data access very fast)
Function ArrayFromRange(varRange As Variant)
Dim rng As Range
Dim A() As Variant
Set rng = varRange
'Check for degenerate cases
If rng Is Nothing Then
'do nothing
ElseIf rng.count = 0 Then
'do nothing
ElseIf rng.count = 1 Then
ReDim A(1 To 1, 1 To 1)
A(1, 1) = rng.Value
Else
A = rng.Value
End If
ArrayFromRange = A
End Function
Finally, go to your Array Formula area and paste in the following Array formula for the "Sales < 5" list: {=AreaUniqueCustomersLessThan(D$11:D$16, G$2:G$7, I$2:I$7,J$2:J$7,E$2:E$7)} Note that the first range must be the same length as the Array Formula range itself. And the other four ranges (the source data ranges) should all be the same length (they do not have to be the same length as the first range).