I am looking to count the occurrences of consecutive numbers in a column and cannot seem to find a logical way to calculate this within a loop.
My column of values is simply entries of 0 or 1. What I want to is count each time there is two 0's in a row, three 0's a row, four 0's in a row and so on. The maximum number of times I would expect a consecutive number is 15.
Ideally, I would like the output for each occurrence entered into a table.
I have provided a snapshot below of the column in question.
My attempts so far consist of looping through the column checking for two 0's in a row, starting at row 2 but this causes issues when I have more than two 0's in a row.
'Check for 2
Dim TwoCount, RowNo As Integer, LastRow As Long
LastRow = Sheets("Data").Range("A165536").End(xlUp).Row
TwoCount = 0
RowNo = 2
For i = 2 To LastRow
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
RowNo = RowNo + 1
Else
If Sheets("Data").Range("H" & RowNo).Value = 0 Then
TwoCount = 1
RowNo = RowNo + 1
If Sheets("Data").Range("H" & RowNo).Value = 0 Then
TwoCount = 2
RowNo = RowNo + 1
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
End If
End If
End If
End If
Next i
I welcome any suggestions to how I should approach this? Whether it's easier as a formula or array formula.
Desired output
Count Consecutive Occurrences
Option Explicit
Sub CountConsecutive()
' Source
Const sName As String = "Data"
Const sFirstCellAddress As String = "H1"
Const sCriteria As Variant = 0
' Destination
Const dName As String = "Data"
Const dFirstCellAddress As String = "J1"
Dim dHeaders As Variant
dHeaders = VBA.Array("Occurrences", "Number of Times")
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source column to an array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim Data As Variant
Dim rCount As Long
With sws.Range(sFirstCellAddress)
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then Exit Sub
rCount = slCell.Row - .Row + 1
If rCount < 2 Then Exit Sub
Data = .Resize(rCount).Value
End With
' Count the occurrences by using a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Long
Dim r As Long
Dim cCount As Long
Dim MaxCount As Long
For r = 2 To rCount
Key = Data(r, 1)
If IsNumeric(Key) Then
If Key = sCriteria Then
cCount = cCount + 1
Else
If cCount > 0 Then
dict(cCount) = dict(cCount) + 1
If cCount > MaxCount Then MaxCount = cCount
cCount = 0
End If
End If
End If
Next r
If MaxCount = 0 Then Exit Sub
' Write the values from the dictionary to the array.
rCount = MaxCount + 1
ReDim Data(1 To rCount, 1 To 2)
Data(1, 1) = dHeaders(0)
Data(1, 2) = dHeaders(1)
For r = 2 To rCount
Data(r, 1) = r - 1
If dict.Exists(r - 1) Then
Data(r, 2) = dict(r - 1)
Else
Data(r, 2) = 0
End If
Next r
' Write the values from the array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 2)
.Resize(rCount).Value = Data
.Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
'.Font.Bold = True
'.EntireColumn.AutoFit
End With
'wb.save
MsgBox "Consecutive count created.", vbInformation
End Sub
COUNTING THE FREQUENCY OF CONSECUTIVE OCCURRENCES OF 0 IN A COLUMN
You may try this array formula as well,
• Formula used in cell L2
=SUMPRODUCT(--(FREQUENCY(
IF($H$2:$H$32=0,ROW($H$2:$H$32)),
IF($H$2:$H$32=1,ROW($H$2:$H$32)))=K2))
And Fill Down!
Note: Array formulas need to be entered by pressing CTRL + SHIFT + ENTER (not just ENTER). Hold down both the CTRL key and the SHIFT key then hit ENTER. If you are using Excel 2021 or O365 you can only press ENTER.
Imagine your numbers Win/Lose in column A then add in cell B3 (not B2 this will stay empty) the following formula and copy it down:
=IF(AND(A3=0,A3<>A4),COUNTIF($A$2:A3,A3)-SUM($B$2:B2),"")
Then to count them just use =COUNTIF(B:B,E2) in F2 and copy it down.
You can read this requirements in two ways as I see it:
You can count an occurence of 1,2,3 and 4 in a sequence of 4 zero's;
You can count only the max occurence of the above;
I went with the assumptions of the latter:
Formula in C1:
=LET(X,SEQUENCE(15),Y,LEN(TEXTSPLIT(CONCAT(IF(A2:A32," ",1)),," ",1)),VSTACK({"Occurences of 0","Number of Times"},HSTACK(X,BYROW(X,LAMBDA(a,SUM(--(Y=a)))))))
Important note:
It may not be best to rely on CONCAT() since depending on the amount of rows you want to concatenate, it may strike a character limit. Instead you could try something like:
=LET(X,SEQUENCE(15),Y,LEN(TEXTSPLIT(REDUCE("",A2:A32,LAMBDA(a,b,a&IF(b," ",1))),," ",1)),VSTACK({"Occurences of 0","Number of Times"},HSTACK(X,BYROW(X,LAMBDA(a,SUM(--(Y=a)))))))
Also, please note that ms365 is required for the above functions to run properly (and at time of writing VSTACK(), HSTACK() and TEXTSPLIT() are still in the insider's BETA-channels.
Related
I'm a VBA noob. I need help working out this filter:
My data has ~50,000 rows and 100 columns. The column I want to filter has values like TL-98.263138472% BD-1.736861528%. I want to filter out all the values in VBA where TL>90%. I can think of a long way of doing it - where I create a loop, break down each cell, then look at TL, then the 4 numbers next to it. But it sounds like it would take forever. Wondering if there's a faster/easier way to do it? Also wondering, if it's even worth it. If it would take even more than 2 seconds, then I would rather not do it with VBA.
I have not coded it yet, wanted to see if anyone has better ideas than what I came up with.
Thanks in advance! Adding an example of my data below:
Pretty fast in my tests:
Sub tester()
Dim ws As Worksheet, t
Dim i As Long, rng As Range, rngFilt As Range, arr, arrFilt
' For i = 2 To 50000 'create some dummy data
' Cells(i, "A") = "TL-" & 50 + (Rnd() * 60) & "% BD-1.736861528%"
' Next i
' [B2:CV50000].value="blah" 'fill rest of table
t = Timer
Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Set rng = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) 'range of values to filter
Set rngFilt = rng.Offset(0, 110) 'a range off to the right to filter on
arr = rng.Value
arrFilt = rngFilt.Value 'for holding filtering flags
arrFilt(1, 1) = "Filter" 'column header
For i = 2 To UBound(arr, 1)
arrFilt(i, 1) = IIf(FilterOut(arr(i, 1)), "Y", "N")
Next i
rngFilt.Value = arrFilt
rngFilt.AutoFilter field:=1, Criteria1:="N"
Debug.Print Timer - t
End Sub
'does this value need to be filtered out?
Function FilterOut(v) As Boolean
Dim pos As Long
pos = InStr(v, "TL-")
If pos > 0 Then
v = Mid(v, pos + 3)
pos = InStr(v, "%")
If pos > 0 Then
v = Left(v, pos - 1)
'Debug.Print v
If IsNumeric(v) Then FilterOut = v > 90
End If
End If
End Function
This ran in <0.3 sec for me, on a 50k row X 100 col dataset
Filter Via Table Helper Column and String Parse
It you want to look into non VBA solutions, You could use a helper column to decide it it's worth filtering out.
First we need to find "TL-" in the string, then find "%" After that:
MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3)
This will just return us that value sub string, regardless or position.
Now we need to convert it into a value... and I'm told that --( ) isn't the correct way to convert a string to a value... but i keep using it and it keeps working.
Anyway, finally we test if that is larger than 90 like:
=IF(--(MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3))>90,"Remove","Keep")
Here's my example:
And the final result.
And Filtered:
Copy Values (Efficiently!?)
The Code
Option Explicit
Sub CopyData()
Dim T As Double: T = Timer
' Read Data: Write the values from the source range to an array.
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const SRC_COLUMN As Long = 44
Const CRIT_STRING_LEFT As String = "TL-"
Const CRIT_VALUE_GT As Double = 90
Const DST_NAME As String = "Sheet2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Write to the array (practically this line uses up all the time).
Dim Data(): Data = srg.Value ' assumes at least two cells in 'srg'
Debug.Print "Read Data: " & Format(Timer - T, "0.000s")
T = Timer
' Modify Data: Write the critical values to the top of the array.
Dim cLen As Long: cLen = Len(CRIT_STRING_LEFT)
Dim dr As Long: dr = 1 ' skip headers
Dim sr As Long, c As Long
Dim cPos As Long, cNum As Double, cString As String
For sr = 2 To srCount ' skip headers
cString = CStr(Data(sr, SRC_COLUMN))
cPos = InStr(1, cString, CRIT_STRING_LEFT, vbTextCompare)
If cPos > 0 Then
cString = Right(cString, Len(cString) - cPos - cLen + 1)
cString = Replace(cString, "%", "")
cNum = Val(cString) ' 'Val' doesn't work with "!,#,#,$,%,&,^"
If cNum > CRIT_VALUE_GT Then ' 'Evaluate' is too slow!
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
Debug.Print "Modify Data: " & Format(Timer - T, "0.000s")
T = Timer
' Write Data: Write the values from the array to the destination range.
If dr = 0 Then Exit Sub ' no filtered values
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim drg As Range: Set drg = dws.Range("A1").Resize(dr, cCount)
' Write to the range (practically this line uses up all the time).
drg.Value = Data
' Clear below
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
Debug.Print "Write Data: " & Format(Timer - T, "0.000s")
MsgBox "Data copied.", vbInformation
End Sub
The Result (Time Passed)
On a sample of 50k rows by 100 columns of data with 26k matches, the code finished in under 5s:
Read Data: 1.336s
Modify Data: 0.277s
Write Data: 3.375s
There were no blank cells and each cell in the criteria column contained the criteria string with a percentage hence it should be faster on your data. Your feedback is expected.
hello i worte a funnction that sums ahe abslute diffrence betwen two cells each time and then i subtact 70000 from the sum
i would like to to this in vba more aesthetic
70000-(IF(D2>0,ABS(D2-C2))+IF(E2>0,ABS(E2-D2))+IF(F2>0,ABS(F2-E2))+IF(G2>0,ABS(G2-F2))+IF(H2>0,ABS(H2-G2))+IF(I2>0,ABS(I2-H2))+IF(J2>0,ABS(J2-I2))+IF(K2>0,ABS(K2-J2))+IF(L2>0,ABS(L2-K2))+IF(M2>0,ABS(M2-L2))+IF(N2>0,ABS(N2-M2))+IF(O2>0,ABS(O2-N2)) )
Why not simply:
=70000-SUMPRODUCT(ABS(D2:O2-C2:N2),N(D2:O2>0))
Maybe a bit off-topic since you specifically ask for a VBA solution, but this formula-solution would also bring aesthetic and improves calculation:
=70000-
REDUCE(0, COLUMN(C:N),
LAMBDA(a, b,
LET(offset,INDEX(2:2,,b+1),
IF(offset>0,
a+ABS(offset-INDEX(2:2,,b)),
a))))
It loops through column C:N (b) in the row mentioned (row 2:2 in this case) and checks if the value offset 1 to the right (I used INDEX to not make it volatile, but named it offset).
If the value in that row/column+1 is greater than 0 than value a becomes a + ABS(the value in the row/column+1 - value in that row/column), otherwise a stays the same.
Edit:
For if your range might grow/decrease this may be a nice dynamic solution:
=70000-LET(range,C2:Z2,
cols,DROP(FILTER(COLUMN(range),range<>""),,-1),
REDUCE(0,cols,LAMBDA(a,b,LET(offset,INDEX(2:2,,b+1),IF(offset>0,a+ABS(offset-INDEX(2:2,,b)),a)))))
It checks for any values in the range C2:Z2 (Z could be expanded) and filters out the blanks.
Than it takes all columns in the range minus the last (for the offset calculation purpose).
Note that if there are gaps in your data this would filter those out as well.
First, based on your formula, you rather only add the absolute difference if the value subtracted from is >0. If this is what you want, then you would have something like this:
Sub SumAbsDiff()
Dim i As Integer
Dim sum As Double
'This loops from col D to col O
For i = 4 To 15 Step 1
If Cells(2, i).Value > 0 Then sum = sum + Abs(Cells(2, i).Value - Cells(2, i - 1).Value)
Next i
'Change this to the cell you would like to display the value
Cells(1, 1).Value = 70000 - sum
End Sub
Explanation:
Here, we are taking row 2, and then looping over from D until O. Using the loop, we absolute subtract each of them (D-C, E-D, etc) if the >0 condition satisfy. The result is then add to the sum variable (which initialize as 0 by default).
After the loop is done, we just simply use it to subtract from 70,000 and then write it to the cell that we wanted.
As a side note, if your original formula was wrong, and you actually want the sum between each of the absolute differences without the >0 condition, then removing the If ... Then would do the trick.
Sum Up Absolute Differences
Static (C2:O2)
Sub SumUpAbsStatic()
Const SRC_NAME As String = "Sheet1"
Const SRC_RANGE As String = "C2:O2"
Const DST_CELL As String = "B2"
Const INIT_VALUE As Double = 70000
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets(SRC_NAME)
Dim Data(): Data = ws.Range(SRC_RANGE).Value
Dim pValue: pValue = Data(1, 1)
Dim cValue, c As Long, Total As Double
For c = 2 To UBound(Data, 2)
cValue = Data(1, c)
If IsNumeric(pValue) Then
If IsNumeric(cValue) Then
If cValue > 0 Then Total = Total + Abs(cValue - pValue)
End If
End If
pValue = cValue
Next c
Total = INIT_VALUE - Total
ws.Range(DST_CELL).Value = Total
End Sub
Dynamic (C2:LastColumn2)
Sub SumUpAbsolute()
Const SRC_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "C2"
Const DST_CELL As String = "B2"
Const INIT_VALUE As Double = 70000
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets(SRC_NAME)
Dim srg As Range, cCount As Long
With ws.Range(SRC_FIRST_CELL)
Dim lCell As Range: Set lCell = .Resize(, ws.Columns.Count _
- .Column + 1).Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
cCount = lCell.Column - .Column + 1
Set srg = .Resize(, cCount)
End If
End With
Dim Total As Double
If cCount > 1 Then
Dim Data(): Data = srg.Value
Dim pValue: pValue = Data(1, 1)
Dim cValue, c As Long
For c = 2 To cCount
cValue = Data(1, c)
If IsNumeric(pValue) Then
If IsNumeric(cValue) Then
If cValue > 0 Then Total = Total + Abs(cValue - pValue)
End If
End If
pValue = cValue
Next c
End If
Total = INIT_VALUE - Total
ws.Range(DST_CELL).Value = Total
End Sub
You can achieve this in VBA using a for loop:
Sub AbsoluteDifference(n As Double, startCell As String, outputCell As String)
' Store variables as double to account for large numbers and decimals
Dim sum As Double
sum = 0
'Range until the last filled cell
For Each i In Range(startCell, Range(startCell).End(xlToRight)).Cells
If i.Value > 0 Then
sum = sum + Abs(i.Value - i.Offset(0, -1).Value)
End If
Next i
' Save the value to outputCell
Range(outputCell).Value = n - sum
End Sub
' Run the Main sub to call AbsoluteDifference with parameters
Sub Main()
Call AbsoluteDifference(70000, "D2", "C3")
End Sub
This code produces an identical result to your function.
A good solution to this question for one row in excel sheet was offered in another post by user Tony Dallimore.
In the case of a worksheet that contains the following data in one row:
A B C
abc,def,ghi,jkl 1,2,3 a1,e3,h5,j8
After applying the following VBA macro:
Sub Combinations()
Dim ColCrnt As Long
Dim ColMax As Long
Dim IndexCrnt() As Long
Dim IndexMax() As Long
Dim RowCrnt As Long
Dim SubStrings() As String
Dim TimeStart As Single
TimeStart = Timer
With Worksheets("Combinations")
' Use row 1 as the source row. Find last used column.
ColMax = .Cells(1, Columns.Count).End(xlToLeft).Column
' Size Index arrays according to number of columns
' Use one based arrays so entry number matches column number
ReDim IndexCrnt(1 To ColMax)
ReDim IndexMax(1 To ColMax)
' Initialise arrays
For ColCrnt = 1 To ColMax
SubStrings = Split(.Cells(1, ColCrnt).Value, ",")
' SubStrings is a zero-based array with one entry
' per comma separated value.
IndexMax(ColCrnt) = UBound(SubStrings)
IndexCrnt(ColCrnt) = 0
Next
RowCrnt = 3 ' Output generated values starting at row 3
Do While True
' Use IndexCrnt() here.
' For this version I output the index values
For ColCrnt = 1 To ColMax
SubStrings = Split(.Cells(1, ColCrnt).Value, ",")
.Cells(RowCrnt, ColCrnt).Value = SubStrings(IndexCrnt(ColCrnt))
Next
RowCrnt = RowCrnt + 1
' Increment values in IndexCrnt() from right to left
For ColCrnt = ColMax To 1 Step -1
If IndexCrnt(ColCrnt) < IndexMax(ColCrnt) Then
' This column's current index can be incremented
IndexCrnt(ColCrnt) = IndexCrnt(ColCrnt) + 1
Exit For
End If
If ColCrnt = 1 Then
' Leftmost column has overflowed.
' All combinations of index value have been generated.
Exit Do
End If
IndexCrnt(ColCrnt) = 0
' Loop to increment next column
Next
Loop
End With
Debug.Print Format(Timer - TimeStart, "#,###.##")
End Sub
The result is all combinations of data in different columns, while these combinations are displayed in the same worksheet, starting with the third row: (part of the output is displayed below)
abc 1 a1
abc 2 a1
abc 3 a1
abc 1 e3
abc 2 e3
abc 3 h5
However, I would be interested in how this VBA macro can be modified so that it is applied sequentially to more than one row (for any number of rows), while the output would be displayed either two rows below the last row of the input table or on the next worksheet. Unfortunately, my attempts at modification were unsuccessful. thanks in advance for every answer and at the same time this is my first post on stackoverflow, so sorry for any mistakes in the structure of the question.
Example of input table:
A B C
abc,def 1,2 a1,e3
abc,def 1,2 a1,e3
Example of output table:
A B C
abc 1 a1
abc 1 e3
abc 2 a1
abc 2 e3
def 1 a1
def 1 e3
def 2 a1
def 2 e3
abc 1 a1
abc 1 e3
abc 2 a1
abc 2 e3
def 1 a1
def 1 e3
def 2 a1
def 2 e3
Here's another approach that should work, it's a bunch of nested for loops to enumerate all the possible combinations. I'd just do a remove duplicates at the end, this should be pretty fast. Alternatively, using a dictionary would work too.
Sub CreateCombos()
Dim ColumnA As Variant
Dim ColumnB As Variant
Dim ColumnC As Variant
Dim i As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim j As Long
Dim results As Variant
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
'Create an array large enough to hold all the values
ReDim results(1 To 3, 1 To 50000)
'Iterate each of the combinations listed as comma separated values
'Should be easy to make this dynamic if you need to iterate specific cells
For i = 1 To 2
ColumnA = Split(ws.Cells(i, 1), ",")
ColumnB = Split(ws.Cells(i, 2), ",")
ColumnC = Split(ws.Cells(i, 3), ",")
For a = LBound(ColumnA) To UBound(ColumnA)
For b = LBound(ColumnB) To UBound(ColumnB)
For c = LBound(ColumnC) To UBound(ColumnC)
j = j + 1
results(1, j) = ColumnA(a)
results(2, j) = ColumnB(b)
results(3, j) = ColumnC(c)
Next
Next
Next
Next
ReDim Preserve results(1 To 3, 1 To j)
ws.Range("A4:C" & (j + 3)) = Application.Transpose(results)
End Sub
Firstly, I would recommend to break the code into separate Subs and/or Functions. This will make it easier to read, edit, maintain, use, etc.
Secondly, supposing the worksheet looks like shown in the table below, you can split the data in each cell into separate 1D arrays and put those arrays in another 1D array. Thus, you'll get something like a 2D array (like because, there may be different number of elements in each array).
Thirdly, create a temporary 1D array (combs) which will store a single value from each column. Make it's length the same as number of columns in the 2D array.
Lastly, start traversing through the first column of the 2D array (cell A1) and put the values into combs (column number in combs refers to current column number in the 2D array). Then, if it isn't the last column, recursively call this Sub (combinations), else, print the combination (the joint combs).
A
B
C
D
1
abc,def,ghi,jkl
1,2,3
a1,e3,h5,j8
2
The code:
Private Sub read2D(ByRef arr2D() As Variant)
Dim r As Integer
Dim c As Integer
r = 1
For c = 1 To 3
arr2D(c) = Split(Sheet1.Cells(r, c).Value, ",")
Next c
End Sub
Private Sub combinations( _
ByRef combs() As Variant, _
ByRef arr2D() As Variant, _
Optional ByRef c As Integer = 1)
Dim r As Integer
For r = LBound(arr2D(c)) To UBound(arr2D(c))
combs(c) = arr2D(c)(r)
If (c + 1) <= UBound(arr2D) Then
Call combinations(combs, arr2D, c + 1)
Else
Debug.Print Join(combs, " ")
End If
Next r
End Sub
Private Sub main()
Dim arr2D(1 To 3) As Variant
Dim combs(1 To 3) As Variant
Call read2D(arr2D)
Call combinations(combs, arr2D)
End Sub
The output:
abc 1 a1 abc 1 e3 abc 1 h5 abc 1 j8
abc 2 a1 abc 2 e3 abc 2 h5 abc 2 j8
abc 3 a1 abc 3 e3 abc 3 h5 abc 3 j8
def 1 a1 def 1 e3 def 1 h5 def 1 j8
def 2 a1 def 2 e3 def 2 h5 def 2 j8
def 3 a1 def 3 e3 def 3 h5 def 3 j8
ghi 1 a1 ghi 1 e3 ghi 1 h5 ghi 1 j8
ghi 2 a1 ghi 2 e3 ghi 2 h5 ghi 2 j8
ghi 3 a1 ghi 3 e3 ghi 3 h5 ghi 3 j8
jkl 1 a1 jkl 1 e3 jkl 1 h5 jkl 1 j8
jkl 2 a1 jkl 2 e3 jkl 2 h5 jkl 2 j8
jkl 3 a1 jkl 3 e3 jkl 3 h5 jkl 3 j8
Here's one approach:
Sub Combos()
Dim rw As Range, col As Collection, c As Range, list
Dim cDest As Range
Set rw = Range("A1:C1") 'first input row
Set cDest = Range("H1") 'output start position
'loop while have input data
Do While Application.CountA(rw) = rw.Cells.Count
Set col = New Collection
For Each c In rw.Cells
col.Add Split(c.Value, ",") 'add arrays to the collection
Next c
list = CombineNoDups(col)
cDest.Resize(UBound(list, 1), UBound(list, 2)).Value = list
Set cDest = cDest.Offset(UBound(list, 1)) 'move insertion point down
Set rw = rw.Offset(1) 'next input row
Loop
End Sub
'make all combinations of elements in a collection of 1-d arrays
Function CombineNoDups(col As Collection)
Dim rv(), tmp()
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long, x As Long
Dim numIn As Long, s As String, r As Long, v, dup As Boolean
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(1 To t, 1 To numIn) 'resize destination array
x = 0
For n = 1 To t
ReDim tmp(1 To numIn)
dup = False
For i = 1 To numIn
v = col(i)(pos(i))
If Not IsError(Application.Match(v, tmp, 0)) Then
dup = True
Exit For
Else
tmp(i) = v
End If
Next i
If Not dup Then
x = x + 1
For i = 1 To numIn
rv(x, i) = tmp(i)
Next i
End If
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
CombineNoDups = rv
End Function
Get Row Combinations
The GetRowCombinations function will return the combinations in a 2D one-based array to easily be dropped on the worksheet as illustrated in the GetRowCombinationsTEST procedure.
Sub GetRowCombinationsTEST()
Const ProcName As String = "GetRowCombinationsTEST"
On Error GoTo ClearError
' Define constants.
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
Const Delimiter As String = ","
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Using the 'RefCurrentRegion' function, reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range: Set srg = RefCurrentRegion(sfCell)
' Using the 'GetRowCombinations' function, return the combinations
' in a 2D one-based array, the destination array ('dData').
Dim dData As Variant: dData = GetRowCombinations(srg, Delimiter)
Dim drCount As Long: drCount = UBound(dData, 1)
Dim dcCount As Long: dcCount = UBound(dData, 2)
' Reference the destination range ('drg').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
' Write the values from the destination array to the destination range.
drg.Value = dData
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
MsgBox drCount & " combinations generated.", vbInformation
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Function GetRowCombinations( _
ByVal srg As Range, _
ByVal Delimiter As String) _
As String()
Const ProcName As String = "GetRowCombinations"
On Error GoTo ClearError
' Write the number of rows and columns to variables ('srCount','scCount').
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCount As Long: scCount = srg.Columns.Count
' Some rows may be blank, and some rows may have blank cells.
' The Source Row Numbers array ('srNumbers') will hold the indexes
' of the non-blank rows.
Dim srNumbers() As Long: ReDim srNumbers(1 To srCount)
' The Destination Column Counts array ('dcCounts') will hold
' the number of non-blank cells per non-blank row.
Dim dcCounts() As Long: ReDim dcCounts(1 To srCount)
Dim sr As Long ' Current Source Row
Dim dcCount As Long ' (Current and Final (Max)) Destination Columns Count
Dim rCount As Long ' Source Number of Non-Blank Rows
For sr = 1 To srCount
dcCount = scCount - Application.CountBlank(srg.Rows(sr))
If dcCount > 0 Then ' the row is not blank
rCount = rCount + 1
srNumbers(rCount) = sr
dcCounts(rCount) = dcCount
'Else ' the row is blank; do nothing
End If
Next sr
If rCount = 0 Then Exit Function ' all rows are blank
If rCount < srCount Then
ReDim Preserve srNumbers(1 To rCount)
ReDim Preserve dcCounts(1 To rCount)
End If
dcCount = Application.Max(dcCounts)
' Write the values from the range to the Source array ('sData')
Dim sData() As Variant: sData = srg.Value
' The Substrings Data array ('ssData') will hold the zero-based
' string arrays created by using the Split function on each string.
Dim ssData() As Variant: ReDim ssData(1 To rCount, 1 To dcCount)
' The Substrings Uppers array ('ssUppers') will hold the upper limits
' of the corresponding arrays in the Substrings Data array.
Dim ssUppers() As Long: ReDim ssUppers(1 To rCount, 1 To dcCount)
Dim r As Long ' Current Row
Dim sc As Long ' Current Source Column
Dim dc As Long ' Current Destination Column
Dim drCount As Long ' (Final, Cumulative) Destination Rows Count
Dim dprCount As Long ' Destination Rows Count Per Row
Dim sString As String ' Current Source String
For r = 1 To rCount
dprCount = 1
For sc = 1 To scCount
sString = CStr(sData(srNumbers(r), sc))
If Len(sString) > 0 Then ' cell is not blank
dc = dc + 1
ssData(r, dc) = Split(sString, Delimiter)
ssUppers(r, dc) = UBound(ssData(r, dc))
dprCount = dprCount * (ssUppers(r, dc) + 1)
Else ' cell is blank; do nothing
End If
Next sc
drCount = drCount + dprCount
dc = 0
Next r
Erase sData
Erase srNumbers
' The Substrings Indices array ('ssUppers') will hold the current indexes
' of the corresponding arrays in the Substrings Data array.
Dim ssIndices() As Long: ReDim ssIndices(1 To rCount, 1 To dcCount)
' Define the Destination array ('dData').
Dim dData() As String: ReDim dData(1 To drCount, 1 To dcCount)
Dim dr As Long ' Current Destination Row (Combination)
For r = 1 To rCount
dcCount = dcCounts(r)
Do
dr = dr + 1
For dc = 1 To dcCount
dData(dr, dc) = ssData(r, dc)(ssIndices(r, dc))
Next dc
For dc = dcCount To 1 Step -1
If ssIndices(r, dc) = ssUppers(r, dc) Then
If dc = 1 Then
Exit Do
Else
ssIndices(r, dc) = 0
End If
Else
ssIndices(r, dc) = ssIndices(r, dc) + 1
Exit For
End If
Next dc
Loop
Next r
GetRowCombinations = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I have:
Column A: (IDs)
A
A
A
C
C
Z
Column B: (Values)
3
2
-6
-12
6
2
I'm trying to create a macro that fills all unique ID's into column C, and counts whether they pass/fail in column D. A pass would be having an associated value in column B between -5 and 5.
Column C/D would look like:
C
D
A
2
C
0
Z
1
If anyone can start me off or link a similar example id appreciate.
You can do it using formulas. But if you like/want VBA, please try the next piece of code. It uses arrays and a dictionary. Working only in memory, it should be very fast, even for large ranges:
Sub CountPassed()
Dim dict As Object, sh As Worksheet, lastR As Long
Dim arr, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).value 'place the range in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr) 'extract unique keys and their item value according to the rule:
dict(arr(i, 1)) = dict(arr(i, 1)) + IIf(arr(i, 2) >= -5 And arr(i, 2) <= 5, 1, 0)
Next i
'create the necessary final array:
ReDim arrFin(1 To dict.count, 1 To 2)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = dict.items()(i)
Next i
'drop the final array at once
sh.Range("C2").Resize(UBound(arrFin), 2).value = arrFin
End Sub
Count Unique With Limits
Adjust the values in the constants section.
Option Explicit
Sub CountUniqueWithLimits()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "C1"
Const lLimit As String = ">=-5"
Const uLimit As String = "<=5"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim rCount As Long
With sws.Range(sFirstCellAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
rCount = lCell.Row - .Row + 1
Set srg = .Resize(rCount, 2)
End With
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim nkey As Variant
Dim r As Long
For r = 1 To rCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
If Not dict.Exists(Key) Then
dict(Key) = 0
End If
nkey = Data(r, 2)
If IsNumeric(nkey) Then
If Len(nkey) > 0 Then
If Evaluate(nkey & lLimit) Then
If Evaluate(nkey & uLimit) Then
dict(Key) = dict(Key) + 1
End If
End If
End If
End If
End If
End If
Next r
rCount = dict.Count
If rCount = 0 Then Exit Sub
ReDim Data(1 To rCount, 1 To 2)
r = 0
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = dict(Key)
Next Key
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 2)
.Resize(rCount).Value = Data
.Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
End With
MsgBox "Unique values with limits counted.", vbInformation
End Sub
Well, it may happen you are not familiar of writing VBA Codes, then you may try any of the options using Excel Formula (Formulas Shown Below Are Exclusively For Excel 2021 & O365 Users)
=CHOOSE({1,2},UNIQUE(ID),COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5"))
In the above formula, we are combining two arrays within a CHOOSE Function.
• The first array contains the unique values in the database
UNIQUE(ID)
Where ID refers to the range =$A$3:$A$8, created using the Define Name Manager.
• The second array is essentially the COUNTIFS Function,
COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5")
Where Values refers to the range =$B$3:$B$8, created using the Define Name Manager.
The CHOOSE function combines both the arrays into a single array, which produces as a two-column table as shown in the image below.
Note that we can also use the LET function to elegantly perform, by defining a variable, U to hold the unique values,
• Formula can also be used in cell C3
=LET(U,UNIQUE(ID),CHOOSE({1,2},U,COUNTIFS(ID,U,Values,">=-5",Values,"<=5")))
You may see that this version of the formula calls the UNIQUE function once only, storing the result in U, which is used twice!
I wish to have a VBA macro that will help me to edit values in the column 'C' for each row until the sum value has reached.
However, there are some criteria:
The value has to be smaller than the value in column 'B'
If the value in column 'B' is zero, then the value in column 'C' should be zero
For example:
I have certain values in column A for each row and I want the sum for Column C to be 10. Hence, the VBA will loop and iterate each row in column C and check if the number in Column B is greater than 0, if yes then it will add 1 to it. After going through each row, it will check the sum, if the sum has not reach the certain amount (in this case, it's 10), it will loop back again and add 1 to each row and stop when it reaches the sum.
Example output:
----------------------
Column B | Column C
----------------------
124 | 3
100 | 3
83 | 2
23 | 1
4 | 1
0 | 0
-----------------------
Code:
Sub Loop()
Dim Report As Worksheet
Set Report = Excel.ActiveSheet
Dim cell As Range
Dim i As Integer
Dim total As Integer
total = Range("C8").Value
Range("C2:C7").ClearContents
For total = 0 To 10
For Each cell In Range("C2:C12")
For i = 2 To 7
If Range("B" & i).Value > 0 Then
cell.Value = cell.Value + 1
If cell.Value > Range("B" & i).Value Then
cell.Value = cell.Value
End If
Else:
cell.Value = 0
End If
Next i
Next cell
total = total + Range("C8").Value
Next total
End Sub
However, the output that I got seems to be not my desire output and I got all zeros instead. I am a newbie to VBA :(, can anyone help me with this?
Below is my take on your problem but a couple of things to start...
VBA didn't much like the sub having the name loop as loop is a reserved word
I've used methods intersect and offset when working with ranges but there are multiple ways to skin this cat
Range("C2:C7").ClearContents will result in empty cells and while an empty cell will likely be considered 0 when trying to add 1 to the value, it would perhaps be better to give the cells an explicit value e.g. 0
There exists some cases where a total of, for example, 10 can't be reached and if not tested for and handled, the loop will run forever, never reaching 10
I'm not sure if msgbox is appropriate to your task but I popped it in anyway in case you haven't yet come across it
Sub SomeLoop()
Set totalCell = Range("C8")
Set editableColumnRange = Range("C2:C7")
'set all the editable cells to a default/initial value
editableColumnRange.Value = 0
totalAtEndOfLastLoop = 0
total = 0
Offset = 0
Do While total < 10
'set the current row to the current row offset past the top row of the editable cells
Set currentRowRange = editableColumnRange.Rows(1).EntireRow.Offset(Offset)
Set currentCCell = Intersect(currentRowRange, Range("C:C"))
Set currentBCell = Intersect(currentRowRange, Range("B:B"))
'implement the rules
If currentBCell.Value = 0 Then
currentCCell.Value = 0
ElseIf currentBCell.Value > currentCCell.Value + 1 Then
'to ensure b remains > c, we need to test b > c + 1
'so if c is incremented by 1, it remains less than b
currentCCell.Value = currentCCell.Value + 1
total = total + 1
End If
Offset = Offset + 1
If Offset >= editableColumnRange.Rows.Count Then
'we've got an offset which would task us past the data
'it's time to wrap around
'check if the total has changed otherwise we'll be stuck in the loop forever
If total > totalAtEndOfLastLoop Then
totalAtEndOfLastLoop = total
Offset = 0
Else
MsgBox "The total hasn't changed"
Exit Do
End If
End If
Loop
End Sub
Increment While Less Than
Adjust the values in the constants section and the worksheets (possibly workbooks).
Option Explicit
Sub doIncrement()
' Constants
Const sFirst As String = "B2"
Const dFirst As String = "C2"
Const iTotal As Long = 10
' Worksheets (could be different)
Dim sws As Worksheet: Set sws = ActiveSheet
Dim dws As Worksheet: Set dws = ActiveSheet
' Create a reference to the Source Range.
Dim srg As Range
With sws.Range(sFirst)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
Set srg = .Resize(lCell.Row - .Row + 1)
End With
' Write values from Source Range to Source Array.
Dim rCount As Long: rCount = srg.Rows.Count
Dim sData As Variant
If rCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData = srg.Value
Else
sData = srg.Value
End If
' Define Destination Array.
Dim dData() As Long: ReDim dData(1 To rCount, 1 To 1) ' Long: all zeros
Dim r As Long
Dim dTotal As Long
' Loop through rows of Source Array and write to rows of Destination Array.
Do
For r = 1 To rCount
If sData(r, 1) - dData(r, 1) > 1 Then
dData(r, 1) = dData(r, 1) + 1
dTotal = dTotal + 1
If dTotal = iTotal Then
Exit Do
End If
End If
Next r
Loop
With dws.Range(dFirst)
' Write values from Destination Array to Destination Range.
.Resize(rCount).Value = dData
' Clear contents below.
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End With
End Sub