The code provided below is intended to highlight cells where a negative word is within 5 words of a key word. For the sake of my benefactors privacy I will not provide the keywords I search for however you can see the function of the code. You could put any word as a key word for testing including but not limited to "Micheal", "building", "damage", etc. The code executes it's desired function to a degree however instead of highlighting the individual cells that met the requirement, it highlights the entire selection based off of one cell meeting the requirements. Is there an easy fix or work around for this problem or should I change the for loop to an integer type for loop?
Sub IdentifyCameraPresence()
Application.ScreenUpdating = False
Dim Rng As Range
Dim x As Double, y As Double, i As Double
Dim Negatives As Variant, Keys As Variant, n As Double, k As Double 'keeps track of the location of negatives and key words in a cell
Dim NWords As Variant, KWords As Variant, m As Double, j As Double 'keeps track of the words that are negative and key
Dim Temp As Variant
Set Negatives = CreateObject("System.Collections.ArrayList")
Set Keys = CreateObject("System.Collections.ArrayList")
Set NWords = CreateObject("System.Collections.ArrayList")
NWords.Add "no"
NWords.Add "not"
Debug.Print NWords(0); NWords.Count
Set KWords = CreateObject("System.Collections.ArrayList")
KWords.Add "key1"
KWords.Add "key2"
KWords.Add "key3"
KWords.Add "key4"
KWords.Add "key5"
Debug.Print KWords(3)
Debug.Print "NWords"; NWords.Count; "KWords"; KWords.Count
For Each Rng In Selection
With Application.WorksheetFunction
Temp = Split(Rng)
For i = 0 To UBound(Temp)
Debug.Print "word"; i; ":"; Temp(i)
Next i
For i = 0 To UBound(Temp)
For m = 0 To NWords.Count - 1
If LCase(Temp(i)) = LCase(NWords(m)) Then Negatives.Add i
Next m
For j = 0 To KWords.Count - 1
If InStr(1, LCase(Temp(i)), LCase(KWords(j))) Then Keys.Add i
Next j
Next i
For i = 0 To Negatives.Count - 1
Debug.Print "Negative word"; i; ":"; Negatives(i)
Next i
For i = 0 To Keys.Count - 1
Debug.Print "Key word"; i; ":"; Keys(i)
Next i
'----------------------------PROBLEM IS HERE------------------------------------------------------------
For k = 0 To Keys.Count - 1
For n = 0 To Negatives.Count - 1
Debug.Print "Key"; Keys(k); "negative"; Negatives(n)
Debug.Print "In Color Index"
If Abs(Negatives(n) - Keys(k)) < 5 Then Rng.Interior.ColorIndex = 35
Next n
Next k
'----------------------------PROBLEM IS HERE------------------------------------------------------------
End With
Next Rng
Application.ScreenUpdating = True
End Sub
Related
The code provided below is intended to highlight cells where a negative word is within 5 words of a key word. For the sake of my benefactors privacy I will not provide the keywords I search for however, you can see the function of the code. You could put any word as a key word for testing including but not limited to "Micheal", "building", "damage", etc.
The code executes it's desired function to a degree however instead of highlighting the individual cells that met the requirement, it highlights the entire selection of cells below the first cell that meets the requirements. I feel the issue lies somewhere near the interior color index.
If anyone has any ideas to solve this issue than it'd be greatly appreciated.
Sub IdentifyCameraPresence()
Application.ScreenUpdating = False
Dim Rng As Range
Dim x As Double, y As Double, i As Double, p As Double
Dim Negatives As Variant, Keys As Variant, n As Double, k As Double 'keeps track of the location of negatives and key words in a cell
Dim NWords As Variant, KWords As Variant, m As Double, j As Double 'keeps track of the words that are negative and key
Dim Temp As Variant
Set Negatives = CreateObject("System.Collections.ArrayList")
Set Keys = CreateObject("System.Collections.ArrayList")
Set Rng = Selection
Set NWords = CreateObject("System.Collections.ArrayList")
NWords.Add "no"
NWords.Add "not"
Debug.Print NWords(0); NWords.Count
Set KWords = CreateObject("System.Collections.ArrayList")
KWords.Add "key1"
KWords.Add "key2"
KWords.Add "key3"
KWords.Add "key4"
KWords.Add "key5"
Debug.Print KWords(3)
Debug.Print "NWords"; NWords.Count; "KWords"; KWords.Count
For p = 1 To Rng.Rows.Count
' Debug.Print Rng.Cells(p, 1)
With Application.WorksheetFunction
Temp = Split(Rng(p, 1))
' For i = 0 To UBound(Temp)
' Debug.Print "word"; i; ":"; Temp(i)
' Next i
For i = 0 To UBound(Temp)
For m = 0 To NWords.Count - 1
If LCase(Temp(i)) = LCase(NWords(m)) Then Negatives.Add i
Next m
For j = 0 To KWords.Count - 1
If InStr(1, LCase(Temp(i)), LCase(KWords(j))) Then Keys.Add i
Next j
Next i
' For i = 0 To Negatives.Count - 1
' Debug.Print "Negative word"; i; ":"; Negatives(i)
' Next i
'
' For i = 0 To Keys.Count - 1
' Debug.Print "Key word"; i; ":"; Keys(i)
' Next i
'
''----------------------------PROBLEM IS HERE------------------------------------------------------------
For k = 0 To Keys.Count - 1
For n = 0 To Negatives.Count - 1
Debug.Print "Key"; Keys(k); "negative"; Negatives(n)
Debug.Print "In Color Index"
If Abs(Negatives(n) - Keys(k)) < 5 Then Rng.Cells(p, 1).Interior.ColorIndex = 35
Next n
Next k
''----------------------------PROBLEM IS HERE------------------------------------------------------------
'
End With
Next p
Application.ScreenUpdating = True
End Sub
I used to have a table with a header row of 10 columns each labelled 1-10. I have combined some of the columns so that now my table looks like this.
0-2
3-4
5
6-7
8-9
10
Red
Orange
Yellow
Green
Blue
Black
Given a score of 5 I can use the following to find column C and get "Yellow":
Set range = Worksheets(colorScore).Range("1:1").Find(What:=Score)
But how can I extend that code to lookup a score of 3? or a score of 1?
Lookup with Intervals
It is assumed that the range contains two rows where the first row contains the lookup value (whole number) or an interval of lookup values (whole numbers) and the second row contains the return values.
Option Explicit
Sub TESTlookupRowInterval()
Dim rg As Range: Set rg = Range("A1").CurrentRegion
Dim Result As Variant
Dim i As Long
For i = -5 To 15
Result = lookupRowInterval(rg, i)
If Not IsEmpty(Result) Then
Debug.Print i, Result
End If
Next i
End Sub
' Result
' 0 Red
' 1 Red
' 2 Red
' 3 Orange
' 4 Orange
' 5 Yellow
' 6 Green
' 7 Green
' 8 Blue
' 9 Blue
' 10 Black
Function lookupRowInterval( _
rg As Range, _
ByVal LookupIndex As Long, _
Optional ByVal Delimiter As String = "-") _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count <> 2 Then Exit Function
Dim Data As Variant: Data = rg.Value
With CreateObject("Scripting.Dictionary")
Dim cInterval() As String
Dim j As Long
Dim n As Long
Dim iStart As Long
Dim iEnd As Long
Dim iTemp As Long
For j = 1 To UBound(Data, 2)
cInterval = Split(Data(1, j), Delimiter)
Select Case UBound(cInterval)
Case 0
If isLng(cInterval(0)) Then
.Item(CLng(cInterval(0))) = Data(2, j)
End If
Case 1
If isLng(cInterval(0)) And isLng(cInterval(1)) Then
iStart = CLng(cInterval(0))
iEnd = CLng(cInterval(1))
If iStart > iEnd Then ' Switch.
iTemp = iStart: iStart = iEnd: iEnd = iTemp
End If
For n = iStart To iEnd
.Item(n) = Data(2, j)
Next n
End If
End Select
Next j
If .Count = 0 Then Exit Function
lookupRowInterval = .Item(LookupIndex)
End With
End Function
Function isLng( _
CheckValue As Variant) _
As Boolean
On Error GoTo clearError
Dim Result As Long
If UBound(Split(CheckValue, ".")) = 0 Then ' Allow only whole numbers.
Result = CLng(CheckValue) ' Error if not number.
isLng = True
End If
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function
Dim numCols As Integer
Dim isRng As String
Dim colHeading As String
Dim lowNum As String
Dim highNum As String
Dim num As String
'Count the number of title row cells
numCols = Worksheets(trait).Range("1:1").End(xlToRight).Column
For i = 1 To numCols
colHeading = Worksheets(trait).Cells(1, i).Value
isRng = InStr(colHeading, "-") 'does it have a dash (is it a range)?
If isRng Then 'if it does have a dash...
lowNum = Mid(colHeading, 1, isRng - 1) 'everything before the dash
highNum = Mid(colHeading, isRng + 1) 'everything after the dash
If score >= lowNum And score <= highNum Then 'if your score is between or equal to the low and high numbers...
Debug.Print "Your score come from column " & i
End If
Else 'if it doesn't have a dash...
num = colHeading
If score = num Then
Debug.Print "Your score come from column " & i
End If
End If
Next i
Function ReturnColor(number As Integer) As String
Set Rng = Application.Intersect(Rows(1), ActiveSheet.UsedRange)
ReturnColor = "#no match#"
For Each cl In Rng
a = Split(cl, "-")
Select Case True
Case number < CInt(a(0))
Exit For
Case number = a(0)
ReturnColor = cl.Offset(1): Exit For
Case UBound(a) = 1
If number <= CInt(a(1)) Then ReturnColor = cl.Offset(1): Exit For
End Select
Next
End Function
Sub test()
Dim i As Integer
For i = -5 To 15
Debug.Print "Color for " & i & " is " & ReturnColor(i)
Next
End Sub
I'm currently programming an Excel Function which should return the average of the last 5 non-empty positions of an array. To do that I want to go through the array while inside the function as follows:
Function AVERAGE_LAST_5(rng As Range) As Long
Dim x As Integer, i As Integer, j As Integer, sum As Integer
Dim myArr() As Variant
myArr() = Application.Transpose(Application.Transpose(rng))
x = rng.Count
i = 0:: j = 0:: sum = 0
For i = x To 1 Step -1
If myArr(x).Value <> 0 Then
sum = sum + myArr(x)
j = j + 1
Else
End If
If j = 5 Then Stop
x = x - 1
Next
AVERAGE_LAST_5 = sum / 5
End Function
Problem: the for loop doesn't work, when reaching the first if the program aborts.
Does anyone has had the same problem?
Can anyone help me with it?
myarr will be a two-dimensional array, and not a range. You will need to provide both dimensions:
If isarray(myarr) then
for i = ubound(myarr,1) to lbound(myarr,1) step -1
for j = ubound(myarr,2) to lbound (myarr,2) step -1
if myarr(i,j) <> 0 then
K=k+1
Mysum = mysum + myarr(I,j)
Endif
Next j
Next i
Else ‘ single value
mysum =myarr(I,j)
Endif
Arrays Are Faster
Final Version (Hopefully)
This version additionally has the NumberOfLastValues argument (Required) so you can choose how many values will be summed up and it is shortened with the GoSub...Return statement since the If statement is the same for by rows and by columns.
For some other details look in the First Version below.
Usage
In VBA:
Sub LastAverage()
Debug.Print AvgLast(Range("B4:G14"), 5)
End Sub
In Excel:
=AvgLast(B4:G14,5)
Function AvgLast(SearchRange As Range, ByVal NumberOfLastValues As Long, _
Optional ByVal Row_0_Column_1 As Integer = 0) As Double
Dim vntRange As Variant ' Range Array
Dim i As Long ' Range Array Rows Counter
Dim j As Integer ' Range Array Columns Counter
Dim k As Long ' Values Counter
Dim dblSum As Double ' Values Accumulator
If SearchRange Is Nothing Then Exit Function
vntRange = SearchRange.Value
If Row_0_Column_1 = 0 Then
' By Row
For i = UBound(vntRange) To 1 Step -1
For j = UBound(vntRange, 2) To 1 Step -1
GoSub Calc
Next
Next
Else
' By Column
For j = UBound(vntRange, 2) To 1 Step -1
For i = UBound(vntRange) To 1 Step -1
GoSub Calc
Next
Next
End If
TiDa:
If k > 0 Then
AvgLast = dblSum / k
End If
Exit Function
Calc:
If vntRange(i, j) <> "" And IsNumeric(vntRange(i, j)) Then
k = k + 1
dblSum = dblSum + vntRange(i, j)
If k = NumberOfLastValues Then GoTo TiDa
End If
Return
End Function
First Version
It will return the average if there is at least 1 value and at most 5 values, otherwise it will return 0.
The Row_0_Column_1 arguments parameter is by default 0 and means that the search is done by row (first loop). If it is 1, then the search is done by column (second loop).
The basics are that the range is pasted (depsited) into an array and then the array is searched for existing 'numeric' values and not "" values that are summed up and when reaching the fifth value it 'jumps' out of the loop and divides the sum by 5.
Function AvgLast5(SearchRange As Range, Optional Row_0_Column_1 As Integer = 0) _
As Double
Dim vntRange As Variant ' Range Array
Dim i As Long ' Range Array Rows Counter
Dim j As Integer ' Range Array Columns Counter
Dim k As Long ' Values Counter
Dim dblSum As Double ' Values Accumulator
If SearchRange Is Nothing Then Exit Function
vntRange = SearchRange.Value
If Row_0_Column_1 = 0 Then
' By Row
For i = UBound(vntRange) To 1 Step -1
For j = UBound(vntRange, 2) To 1 Step -1
If vntRange(i, j) <> "" And IsNumeric(vntRange(i, j)) Then
k = k + 1
dblSum = dblSum + vntRange(i, j)
If k = 5 Then GoTo TiDa
End If
Next
Next
Else
' By Column
For j = UBound(vntRange, 2) To 1 Step -1
For i = UBound(vntRange) To 1 Step -1
If vntRange(i, j) <> "" And IsNumeric(vntRange(i, j)) Then
k = k + 1
dblSum = dblSum + vntRange(i, j)
If k = 5 Then GoTo TiDa
End If
Next
Next
End If
TiDa:
If k > 0 Then
AvgLast5 = dblSum / k
End If
End Function
after a couple of tough days at work I've finally got some time to improve my function taking your tips on board.
I've made some changes to enable the function to deal either with 1-Row or 1-Column Ranges. Basic Error handling was also added and a function discripton is as well available (under the FX Excel button).
Feel free to comment and/or use the code.
Here the result:
Function AVERAGE_LAST_N(rng As Range, N As Integer)
Dim NrN As Integer, NrR As Integer, NrC As Integer
Dim i As Integer, j As Integer
Dim sum As Double
Dim myArr As Variant
NrN = rng.Count 'Number of array positions
NrR = rng.Rows.Count 'Number of Rows in the array
NrC = rng.Columns.Count 'Number of Rows in the array
i = 0:: j = 0:: sum = 0 'Counters
'####################################################'
'## Transpose Range into array if row or if column ##'
'####################################################'
If rng.Rows.Count > 1 And rng.Columns.Count = 1 Then 'Transpose a Column Range into an Array
myArr = Application.Transpose(rng)
ElseIf rng.Rows.Count = 1 And rng.Columns.Count > 1 Then 'Transpose a Row Range into an Array
myArr = Application.Transpose(Application.Transpose(rng))
ElseIf rng.Rows.Count > 1 And rng.Columns.Count > 1 Then 'Retunrs an Error if Range is a Matrix *ERR_002*
AVERAGE_LAST_N = "ERR_002"
Exit Function
End If
'####################################################'
'## Transpose Range into array if row or if column ##'
'####################################################'
'################'
'## Start Main ##'
'################'
For i = NrN To 1 Step -1
If IsNumeric(myArr(NrN)) Then
sum = sum + myArr(NrN)
j = j + 1
End If
If j = N Then Exit For
NrN = NrN - 1
Next
AVERAGE_LAST_N = sum / N
'##############'
'## End Main ##'
'##############'
'####################'
'## Error Debuging ##'
'####################'
If j < N Then
AVERAGE_LAST_N = "ERR_001"
Exit Function
End If
'####################'
'## Error Debuging ##'
'####################'
End Function
Sub DescribeFunction()
Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1) As String
FuncName = "AVERAGE_LAST_N"
FuncDesc = "Returns the average of the last N non-empty values in the selected Range"
Category = 14 'Text category
ArgDesc(0) = "Range that contains the values" & Chr(10) & _
"ERR_001 - There are not enought non-empty or null values in the range" & Chr(10) & _
"ERR_002 - Selected range is a matrix and not a row or column range"
ArgDesc(1) = "Dimention of the sample" & Chr(10) & _
"ERR_001 - There are not enought non-empty or null values in the range" & Chr(10) & _
"ERR_002 - Selected range is a matrix and not a row or column range"
Application.MacroOptions _
Macro:=FuncName, _
Description:=FuncDesc, _
Category:=Category, _
ArgumentDescriptions:=ArgDesc
End Sub
'#######################################################################################
' ###############################################
' ############# Error DB ##############
' ###############################################
'
'
' ERR_001 - There are not enought non-empty values in the range
' ERR_002 - Selected range is a matrix and not a row or column range
'
Rafa
I was trying to automate an Excel file which has title in both A and B columns and I have to search each word from A within B and calculate the % by using the "no of words matched/total no of words (in column A)" formula.
I'm using the below code, however its not giving me the accurate % for which the title has repeated words (Duplicate words).
Sub percentage()
Dim a() As String, b() As String
Dim aRng As Range, cel As Range
Dim i As Integer, t As Integer
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
a = Split(Trim(cel), " ")
b = Split(Trim(cel.Offset(, 1)), " ")
d = 0
c = UBound(a) + 1
If cel.Value <> "" Then
If InStr(cel, cel.Offset(, 1)) Then
d = UBound(b) + 1
Else
For i = LBound(a) To UBound(a)
For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
d = d + 1
End If
Next
Next
End If
End If
cel.Offset(0, 2).Value = (d / c)
Next
End Sub
If Title 1 : Really Nice pack with Nice print and Title 2 : Nice Print Nice pack then result should be 3/6 i.e. 67%.
But I'm getting a result as 100%.
Can anyone help me out please.
Titles are
Great job dud
Really Nice pack with Nice print
To give success and success process
Don’t eat too much. If you eat too much you will get sick
I have tried =noDuplicate(celladdress)
First, you should delete duplicate word in column B.
My function delete word and return array of word that not duplicate.
Function noDuplicate(ByVal str As String) As String()
Dim splitStr() As String
Dim result() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim addFlag As Boolean
splitStr = Split(UCase(str), " ")
ReDim result(UBound(splitStr))
'
result(0) = splitStr(0)
k = 0
For i = 1 To UBound(splitStr)
addFlag = True
For j = 0 To k
If splitStr(i) = result(j) Then
addFlag = False
Exit For
End If
Next j
If addFlag Then
result(k + 1) = splitStr(i)
k = k + 1
End If
Next i
ReDim Preserve result(k)
noDuplicate = result
End Function
Then calculate the percentage of number of match word and number of word in column A.
Function percentMatch(ByVal colA As String, ByVal colB As String) As Double
Dim splitColA() As String
Dim splitColB() As String
Dim i As Integer
Dim j As Integer
Dim matchCount As Integer
splitColA = Split(UCase(colA), " ")
splitColB = noDuplicate(colB)
matchCount = 0
For i = 0 To UBound(splitColA)
For j = 0 To UBound(splitColB)
If splitColA(i) = splitColB(j) Then
matchCount = matchCount + 1
Exit For
End If
Next j
Next i
percentMatch = matchCount / (UBound(splitColA) + 1)
End Function
After add these two function, you can write your new code to below
Sub percentage()
Dim aRng As Range, cel As Range
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
cel.Offset(0, 2).Value = percentMatch(cel.Value, cel.Offset(0, 1).Value)
Next
End Sub
Note, I not protect for empty string in the function.
If you F8 through the code, you can see the problem.
The first Nice in column A loops through column B and counts 2 occurences.
Pack in column A loops through column B and counts 1 occurence.
The second Nice in column A loops through column B and counts 2 occurences.
Print in column A loops through column B and counts 1 occurence.
So you get a count of 6 against the 6 words in column A; 100%
If you add a random word to column A, you'll get 6 out of 7.
I am trying to organise a list of data "a,b,c,d,e,...." into all possible combinations of 1,2,3....n elements.
For example:
a,b,c,d,e
a
b
c
d
e
a,b
a,c
a,d
a,e
b,c
b,d
d,e
...
and so on.
So far I have only come across people who have written code to find the combinations to two sets of data rather than one.
Would you know where to start?
In my head it would be similar to the following so it would run systematically, and stops any repeats of the permutations. So essentially I would be running a loop inside another loop 4 or 5 different times.
i
i+1
i+...n
i,j+1
.
.
.
i,j,k,l....
I asked a similar question about 10 years ago and got a great answer from John Coleman:
Gray Code
Here is his solution:
'If you run TestThis, then for example the second message box returns
'
'{}
'dog
'dog , cat
'cat
'cat , mouse
'dog , cat, mouse
'dog , mouse
'mouse
'mouse , zebra
'dog , mouse, zebra
'dog , cat, mouse, zebra
'cat , mouse, zebra
'cat , zebra
'dog , cat, zebra
'dog , zebra
'zebra
'
'Hope this helps,
'
'John Coleman
'p.s. The algorithm used to generate the Gray code comes from the
'excellent book "Combinatorial Algorithms: Generation, Enumeration and
'Search " by Kreher and Stinson."
and the code:
Sub TestThis()
Dim i As Integer
Dim A(3 To 7) As Integer
Dim B As Variant
For i = 3 To 7
A(i) = i
Next i
B = Array("dog", "cat", "mouse", "zebra")
MsgBox ListSubsets(A)
MsgBox ListSubsets(B)
End Sub
Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Integer
Dim i As Integer
Dim lower As Integer, upper As Integer
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = Items(i)
Else
NewSub = NewSub & ", " & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
ListSubsets = SubList
End Function
I know this question is old, but I wrote the code before finding John Coleman's option.
In order to find different rank combinations (i.e. sets of 2,3,4 items) I put the list of items in ColumnA of a clean sheet, with a header, and call it with something like:
Sub call_listcombos()
Dim sht as Worksheet, outrn As Range
Dim n As Integer, r As Integer, rto As Integer
Dim poslist()
Application.ScreenUpdating = False
Set sht = ActiveSheet
n = sht.Range("A1").CurrentRegion.Rows.Count - 1
poslist() = Application.Transpose(sht.Range("A2").Resize(n).Value2)
rto = 2
Do While Application.Combin(n, rto + 1) < 250000
DoEvents
rto = rto + 1
Loop
For r = 2 To rto
Set outrn = sht.Range("A1").Offset(sht.Range("A1").CurrentRegion.Rows.Count)
Call list_combos(poslist(), r, outrn)
Next r
Application.ScreenUpdating = True
End Sub
The code:
Private Sub list_combos(items() As Variant, r As Integer, outrange As Range)
'receives a 1-D variant array and outputs a single column with nCr combinations
'selecting r items without replacement... n > r > 1 :: integers
Dim n As Integer, i As Integer, ri As Integer, outi As Long
Dim comboindex(), comboitems()
n = UBound(items) - LBound(items) + 1
outi = Application.Combin(n, r)
'test output range
If outrange.Row + outi > 1000000 Then
MsgBox "Too many combinations! Will not fit in output range."
Exit Sub
End If
If Application.CountA(outrange.Resize(outi)) > 0 Then
MsgBox "Output range is not empty!"
Exit Sub
End If
'initialize combinations
ReDim comboindex(1 To r)
ReDim comboitems(1 To r)
For ri = 1 To r
comboindex(ri) = LBound(items) + ri - 1 'sets comboindex's base to items' base
comboitems(ri) = items(comboindex(ri))
Next ri
'loop combinations
ri = r
outi = 0
Do While comboindex(ri) <= UBound(items)
DoEvents
For i = comboindex(ri) To UBound(items)
comboindex(ri) = i
comboitems(ri) = items(comboindex(ri))
outrange.Offset(outi).Value2 = Join(comboitems, ";")
outi = outi + 1
Next i
ri = ri - 1
Do While comboindex(ri) + 1 = comboindex(ri + 1)
DoEvents
If ri = 1 Then Exit Do
ri = ri - 1
Loop
comboindex(ri) = comboindex(ri) + 1
comboitems(ri) = items(comboindex(ri))
Do While ri < r
DoEvents
ri = ri + 1
comboindex(ri) = comboindex(ri - 1) + 1
If comboindex(ri) > UBound(items) Then Exit Do
comboitems(ri) = items(comboindex(ri))
Loop
Loop
End Sub