I have this:
| col1 | col2 | col 3 |
| 5 | FA | OFF |
| 107 | FA | ON |
| 96 | FO | ON |
and I want to MsgBox each row like that
Dim str As String
Dim r As Long
r = 2
While Celles(r,1).Value <> ""
str = Rows(r) ' don't know how get row with space between items
MsgBox str
Set WshShell = CreateObject("WScript.Shell")
Set WshShellExec = WshShell.Exec("""C:\mypath\prog.exe"" " & str)
r = r+1
Wend
I want 3 MsgBox to appear 5 FA OFF 107 FA ON 96 FO ON.
Therefore, how to get a row properly and add space between items ?
(After i want to call WshShellExec with parameters)
Sub x()
For i = 1 To 3
a = Application.Transpose(Application.Transpose(Range("a1:c1").Offset(i, 0).Value))
Debug.Print Join(a, "|")
Next i
End Sub
Try the code below to combine the Strings per row:
Option Explicit
Sub CombStringinRow()
Dim str As String
Dim r As Long, Col As Long
Dim LastCol As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row ' get last row with data from column "A"
For r = 2 To LastRow
LastCol = Cells(r, Columns.Count).End(xlToLeft).Column ' get last column in current row
For Col = 1 To LastCol
If str <> "" Then
str = str & " " & Cells(r, Col)
Else
str = Cells(r, Col)
End If
Next Col
MsgBox str
str = ""
Next r
End Sub
Please give this a try...
Sub ConcatenateRowValues()
Dim x
Dim i As Long
Dim Str As String
x = Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
Str = Join(Application.Index(x, i, 0), " ")
MsgBox Str
Next i
End Sub
Give this a go
Sub example()
Dim str As String
Dim r As Long
Dim c
' I'd recommend changing this to your actual sheet
With ActiveSheet
For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
str = vbNullString
For Each c In Range(.Cells(r, 1), .Cells(r, .Cells(r, .Columns.Count).End(xlToLeft).Column))
str = str & " " & c.Value2
Next c
MsgBox WorksheetFunction.Trim(str)
Next r
End With
End Sub
just build str from values in all columns
Dim i as Long 'HERE EDITED
For i = 0 To 2
str = str & " " & Cells(r, 1).Offset(,i) 'HERE EDITED
Next i
MsgBox str
str = ""
Related
transactions sheet
ID1 Name Amount ID2
123 A 1 0;124;0
456 B 2 124;0;0
789 C 3 456;0;0
transactions sheet (Expected Result)
ID1 Name Amount ID2 Summary
123 A 1 0;124;0 124
456 B 2 124;0;0 456
789 C 3 456;0;0
I have tried text to columns but I am unsure on how to ignore all the 0's and only display the value if its >0 in column D. I am new to vba so would appreciate some advice on this so I can learn.
Code:
Sub SplitRange()
Dim cell As Range
Dim str As Variant 'string array
Dim r As Integer
For Each cel In ActiveSheet.UsedRange
If InStr(cell.Value, ";") > 0 Then 'split
str = Split(cell.Value, ";")
For r = LBound(str) To UBound(str)
cel.Offset(r).Value = Trim(str(r))
If r < UBound(str) Then cell.Offset(r + 1).EntireRow.Insert
Next r
End If
Next cell
End Sub
At first we should not loop through all used cells but only the row where these ID2 are that we need, which is a lot faster.
The easiest way would be just to remove all ;0 and 0; then only the value remains. The following will work if there is always only one real value that is not 0 e.g 0;124;0.
Public Sub FindValueRangeInColumn()
Const Col As Long = 4 'the column where the ID2 is in
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row 'find last used row in column
Dim iRow As Long
For iRow = 2 To lRow 'loop throug rows from 2 to last used row
Dim strSource As String
strSource = ws.Cells(iRow, Col) 'read value
strSource = Replace(ws.Cells(iRow, Col), ";0", "") 'remove all ;0
If Left$(strSource, 2) = "0;" Then strSource = Right$(strSource, Len(strSource) - 2) 'remove 0; from the beginnning
ws.Cells(iRow, Col + 1).Value = strSource 'write value
Next iRow
End Sub
If there can be more than 1 non-zero value like 0;124;0;222;0;0;144 then replace
ws.Cells(iRow, Col + 1).Value = strSource 'write value
with a splitting alternative …
If InStr(1, strSource, ";") > 1 Then
Dim SplitValues As Variant
SplitValues = Split(strSource, ";")
Dim iValue As Long
For iValue = LBound(SplitValues) To UBound(SplitValues)
ws.Cells(iRow, Col + 1 + iValue).Value = SplitValues(iValue) 'write value
Next iValue
Else
ws.Cells(iRow, Col + 1).Value = strSource 'write value
End If
Morning,
What you need here is to split the entry into an array and then check the values of the array as you loop the array:
Sub SplitString()
Dim TempArray() As String
Dim i as Integer
Dim j As Integer
For i = 1 To 10
TempArray = Split(Worksheets("Sheet1").Cells(i,4).Value,";")
For j = 0 to UBound(TempArray)
If CDbl(TempArray(j)) <> 0 Then
[Output value]
End if
Next j
Next i
End Sub
Create a more useful loop than 1 = 1 to 10 but you get the idea...
Note in the above:
- The CDbl is to ensure that the check reads it as a number and not a text string.
So, you want to concatenate non-0 values into a string, then put that in the next cell?
Sub SplitRange()
Dim workcell As Range
Dim str() As String 'string array
Dim r As Long 'VBA automatically stores Integers as Longs, so there is no Memory saved by not using Long
Dim output As String
output = ";" 'Start with a single delimiter
For Each workcell In Intersect(ActiveSheet.UsedRange,ActiveSheet.Columns(4)) 'Go down the cells in Column D
If InStr(workcell.Value, ";") > 0 Then 'split
str = Split(workcell.Value,";")
For r = LBound(str) To UBound(str)
If inStr(output, ";" & Trim(str(r)) & ";") < 1 Then 'If number is not already in output
output = output & Trim(str(r)) & ";" 'Add the number and ";" to the end of the string
End If
Next r
Erase str 'Tidy up array, ready to recycle
End If
Next workcell
'We now have a unique list of all items, starting/ending/delimited with ";"
output = Replace(output,";0;",";") 'Remove the item ";0;" if it exists
If Len(output) > 2 Then 'output contains at least 1 non-zero number
output= Mid(output,2,len(output)-2) 'Remove ";" from the start and end
str = Split(output,";") 'Split the list of unique values into an array
For r = lbound(str) To ubound(str)
ActiveSheet.Cells(r+2-lbound(str),5).Value = str(r) 'List the values in column 5, starting from row 2
Next r
Erase str 'Tidy up array
End If
End Sub
To remove "0"s from a single row as an Excel formula, try this:
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE("|;" & A1 & ";|", ";0;",";"),";|",""),"|;","")
From the inside-out:
SUBSTITUTE("|;" & A1 & ";|", ";0;",";") Sandwich our values in wrappers ("|;0;240;0;|") and replace any ";0;" with ";" ("|;240;|")
.
SUBSTITUTE(PREV,";|","") Remove ";|" ("|;240")
.
SUBSTITUTE(PREV,"|;","") Remove "|;" ("240")
I have 2 tables as shown below
Table 1
AA
BB
CC
DD
EE
Table 2
bb
aa
bb1
bb2
cc1
cc2
cc3
I need help to do the below steps using Excel VBA code
Use Table 1 and loop thru each data in table 1 and compare to Table 2
If table 2 only have 1 match, just replace the Table 1 data from the table 2 value on the same row of data from table 1
If have multiple match from table 2, them prompt user to select which data from table 2 need to be written in table 1
Matching Criteria are as follows
AA should match to aa,aa1,aa2,,,,,,
BB shoud match bb,bb1,bb2,,,,,,,,
Below is the code that I have written
Private Sub CommandButton2_Click()
Dim attr1 As Range, data1 As Range
Dim item1, item2, item3, lastRow, lastRow2
Dim UsrInput, UsrInput2 As Variant
Dim Cnt As Integer, LineCnt As Integer
Dim MatchData(1 To 9000) As String
Dim i As Integer, n As Integer, j As Integer, p As Integer
Dim counter1 As Integer, counter2 As Integer
Dim match1(1 To 500) As Integer
Dim matchstr1(1 To 500) As String
Dim tmpstr1(1 To 500) As String
Dim storestr(1 To 500) As String
Dim tmpholderstr As String
counter1 = 1
counter2 = 0
j = 0
p = 0
tmpholderstr = ""
For i = 1 To 500
storestr(i) = ""
Next i
For i = 1 To 500
tmpstr1(i) = ""
Next i
For i = 1 To 500
matchstr1(i) = ""
Next i
For i = 1 To 500
match1(i) = 0
Next i
For i = 1 To 9000
MatchData(i) = ""
Next i
UsrInput = InputBox("Enter Atribute Column")
UsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lastRow = .Cells(.Rows.Count, UsrInput).End(xlUp).Row
'MsgBox lastRow
End With
With ActiveSheet
lastRow2 = .Cells(.Rows.Count, UsrInput2).End(xlUp).Row
'MsgBox lastRow
End With
Set attr1 = Range(UsrInput & "2:" & UsrInput & lastRow)
Set data1 = Range(UsrInput2 & "2:" & UsrInput2 & lastRow2)
'Debug.Print lastRow
'Debug.Print lastRow2
For Each item1 In attr1
item1.Value = Replace(item1.Value, " ", "")
Next item1
For Each item1 In attr1
If item1.Value = "" Then Exit For
counter1 = counter1 + 1
item1.Value = "*" & item1.Value & "*"
For Each item2 In data1
If item2 = "" Then Exit For
If item2 Like item1.Value Then
counter2 = counter2 + 1
match1(counter2) = counter1
matchstr1(counter2) = item2.Value
tmpstr1(counter2) = item1.Value
Debug.Print item1.Row
Debug.Print "match1[" & counter2; "] = " & match1(counter2)
Debug.Print "matchstr1[" & counter2; "] = " & matchstr1(counter2)
Debug.Print "tmpstr1[" & counter2; "] = " & tmpstr1(counter2)
End If
Next item2
Next item1
' Below is the code that go thru the array and try to write to table 1
' But it is not working as expected.
For n = 1 To 500
If matchstr1(n) = "" Then Exit For
If match1(n) <> match1(n + 1) Then
Range("K" & match1(n)) = matchstr1(n)
Else
i = 0
For j = n To 300
If matchstr1(j) = "" Then Exit For
i = i + 1
If match1(j) = match1(j + 1) Then
tmpstr1(i) = matchstr1(j)
End If
Next j
End If
Next n
End Sub
Try the following. Your two tables are suppose to be in a sheet named "MyData", where there is also a command button (CommandButton2). Add also a UserForm (UserForm1), and in that UserForm add another command button (CommandButton1).
In the module associated with CommandButton2, copy the following code:
Public vMyReplacementArray() As Variant
Public iNumberOfItems As Integer
Public vUsrInput As Variant, vUsrInput2 As Variant
Public lLastRow As Long, lLastRow2 As Long
Public rAttr1 As Range, rData1 As Range, rItem1 As Range, rItem2 As Range
Public iCounter1 As Integer
Sub Button2_Click()
vUsrInput = InputBox("Enter Atribute Column")
vUsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lLastRow = .Cells(.Rows.Count, vUsrInput).End(xlUp).Row
End With
With ActiveSheet
lLastRow2 = .Cells(.Rows.Count, vUsrInput2).End(xlUp).Row
End With
Set rAttr1 = Range(vUsrInput & "2:" & vUsrInput & lLastRow)
Set rData1 = Range(vUsrInput2 & "2:" & vUsrInput2 & lLastRow2)
ReDim vMyReplacementArray(1 To 1) As Variant
For Each rItem1 In rAttr1
For Each rItem2 In rData1
If (InStr(1, rItem2, rItem1, vbTextCompare)) > 0 Then
vMyReplacementArray(UBound(vMyReplacementArray)) = rItem1.Value & "-" & rItem2.Value
ReDim Preserve vMyReplacementArray(1 To UBound(vMyReplacementArray) + 1) As Variant
End If
Next rItem2
Next rItem1
iNumberOfItems = UBound(vMyReplacementArray) - LBound(vMyReplacementArray)
UserForm1.Show
End Sub
And in the Userform, the following:
Dim k As Integer
Private Sub UserForm_initialize()
Dim myElements() As String
Dim theLabel As Object
Dim rad As Object
Class1 = ""
k = 1
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
If myElements(0) <> Class1 Then
Set theLabel = UserForm1.Controls.Add("Forms.Label.1", "Test" & i, True)
theLabel.Caption = myElements(0)
theLabel.Left = 80 * k
theLabel.Width = 20
theLabel.Top = 10
k = k + 1
j = 1
End If
Set rad = UserForm1.Controls.Add("Forms.OptionButton.1", "radio" & j, True)
If j = 1 Then
rad.Value = True
End If
rad.Caption = myElements(1)
rad.Left = 80 * (k - 1)
rad.Width = 60
rad.GroupName = k - 1
rad.Top = 50 + 20 * j
j = j + 1
Class1 = myElements(0)
Next i
End Sub
Private Sub CommandButton1_Click()
Dim ctrl As MSForms.Control
Dim dict(5, 1)
Dim i
'## Iterate the controls, and associates the GroupName to the Button.Name that's true.
i = 0
For Each ctrl In Me.Controls
If TypeName(ctrl) = "OptionButton" Then
If ctrl.Value = True Then
dict(i, 0) = ctrl.GroupName
dict(i, 1) = ctrl.Caption
i = i + 1
End If
End If
Next
'For i = 0 To k
'MsgBox "grupo: " & dict(i, 0) & "elem: " & dict(i, 1)
'Next
j = 0
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
For Each rItem1 In rAttr1
If rItem1 = myElements(0) Then
rItem1 = dict(j, 1)
j = j + 1
End If
Next
Next i
End Sub
I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F as seen below.
E.g. on the Emails sheet
becomes this on a new sheet
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
I managed to resolve it with the above code but there are 3 niggling issues:
1) The first curly brace is always copied, how do I omit this so something like {Computer1 looks like Computer 1
2) Where there are two computers in a row, then the output looks something like this:
when it should really be split into two different rows i.e.
User 1 | Computer 1
User 1 | Computer 2
3) If there is text after the last curly brace with text in it e.g. {Computer1};{Computer2};Request submitted then that text is added as a new row, I don't want this, I want it to be omitted e.g.
should just be:
User 1 | Computer 1
User 1 | Computer 2
How do I go about rectifying these issues?
Try this:
Sub Collapse()
Dim uRng As Range, cel As Range
Dim comps As Variant, comp As Variant, r As Variant, v As Variant
Dim d As Dictionary '~~> Early bind, for Late bind use commented line
'Dim d As Object
Dim a As String
With Sheet1 '~~> Sheet that contains your data
Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
End With
Set d = CreateObject("Scripting.Dictionary")
With d
For Each cel In uRng
a = Replace(cel.Offset(0, -3), "{", "}")
comps = Split(a, "}")
Debug.Print UBound(comps)
For Each comp In comps
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
If Not .Exists(cel) Then
.Add cel, comp
Else
If IsArray(.Item(cel)) Then
r = .Item(cel)
ReDim Preserve r(UBound(r) + 1)
r(UBound(r)) = comp
.Item(cel) = r
Else
r = Array(.Item(cel), comp)
.Item(cel) = r
End If
End If
End If
Next
Next
End With
For Each v In d.Keys
With Sheet2 '~~> sheet you want to write your data to
If IsArray(d.Item(v)) Then
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
Else
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
End If
End With
Next
Set d = Nothing
End Sub
Above code uses Replace and Split Function to pass your string to array.
a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter
Then information are passed to dictionary object using User as key and computers as items.
We filter the items passed to dictionary using Instr and Len Function
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then
As I've commented, I assumed your max computer number is 99.
Else change 10 to whatever length you need to check.
Finally we return the dictionary information to the target worksheet.
Note: You need to add reference to Microsoft Scripting Runtime if you prefer early bind
Result: I tried it on a small sample data patterned on how I see it in you SS.
So assuming you have this data in Sheet1:
Will output data in Sheet2 like this:
I use a custom parse function for this type of operation:
Sub CopyConditional()
' some detail left out
Dim iRow&, Usern$, Computer$, Computers$
For iRow = ' firstrow To lastrow
Usern = Sheets("Emails").Cells(iRow, "F")
Computers = Sheets("Emails").Cells(iRow, "C")
Do
Computer = zParse(Computers) ' gets one computer
If Computer = "" Then Exit Do
' Store Computer and Usern
Loop
Next iRow
End Sub
Function zParse$(Haystack$) ' find all {..}
Static iPosL& '
Dim iPosR&
If iPosL = 0 Then iPosL = 1
iPosL = InStr(iPosL, Haystack, "{") ' Left
If iPosL = 0 Then Exit Function ' no more
iPosR = InStr(iPosL, Haystack, "}") ' Right
If iPosR = 0 Then MsgBox "No matching }": Stop
zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
iPosL = iPosR
End Function
1) Use the Mid function to drop the first character:
str = "{Computer1"
str = Mid(str,2)
now str = "Computer1"
2) You can use the Split function to separate these out and combine with the Mid function above
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
result = Mid(splt(a),2)
next a
3) Add a conditional statement to the above loop
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a
Use this loop and send each result to the desired cell (in the for-next loop) and you should be good to go.
I have multiple values in cell A1 which are separated by a ';'. Some of the same values may be in cell B1. I need to search the values in cell A1 using those in cell B1. All the values that are not found then need to presented in cell C1.
Eg - Cell A1 ( Apple;Orange;Cherry) cell B1 (Apple;Orange;) cell c1 need to reflect "Cherry" as not found
I tried this code:
Sub Splitvalue()
Dim str, mystr As Variant
Dim tp As Integer
str = Split(Range("A1").Value, ";")
For tp = LBound(str) To UBound(str)
mystr = str(tp)
Next
End Sub
Set up your sheet1 like this
the use this code
Option Explicit
Sub Splitvalue()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim A As Variant, B As Variant
Dim i As Long, j As Long
Dim x As Boolean
Columns(3).ClearContents
For Each c In Range("A1:A" & lastRow)
A = Split(c, ";")
B = Split(c.Offset(0, 1), ";")
For i = LBound(A) To UBound(A)
For j = LBound(B) To UBound(B)
If A(i) = B(j) Then
x = True
Exit For
Else
x = False
End If
Next j
If Not x Then
If IsEmpty(c.Offset(0, 2)) Then
c.Offset(0, 2) = A(i)
Else
c.Offset(0, 2).Value = c.Offset(0, 2).Value & ";" & A(i)
End If
End If
Next i
Next
End Sub
and your results should look like this
Why not just split the second cell like you split the first cell? Then see if you find each element of A1 in B1, otherwise output to C1?
This is not elegant, but will work:
Sub Splitvalue()
Dim str, mystr As Variant
Dim stri As Variant
Dim tp As Integer
str = Split(Range("A1").Value, ";")
str2 = Split(Range("B1").Value, ";")
For tp = LBound(str) To UBound(str)
mystr = str(tp)
'Debug.Print mystr
Dim found As Boolean
found = False
For Each stri In str2
'Debug.Print stri
If stri = mystr Then
found = True
End If
Next stri
If found = False Then
Debug.Print mystr
End If
Next
End Sub
One way:
dim needle() as string: needle = split(Range("B1").Value, ";")
dim haystack as string: haystack = ";" & Range("A1").Value & ";"
dim i as long
for i = 0 To ubound(needle)
haystack = replace$(haystack, ";" & needle(i) & ";", ";")
next
If len(haystack) = 1 then haystack = ";;"
Range("C1").Value = Mid$(haystack, 2, Len(haystack) - 2)
i need help with the following excel and what looks like a VBA problem.
The idea here is to generate all the possible combination (without repetition) in each grouping.
INPUT
COLUMN A | COLUMN B
A | 1
X | 1
D | 1
C | 2
E | 2
OUTPUT
COLUMN A | COLUMN B
A | X
A | D
X | D
X | A
D | A
D | X
C | E
E | C
What I managed to do.... how do i let it run only if the data is in the same group.
Option Explicit
Sub Sample()
Dim i As Long, j As Long
Dim CountComb As Long, lastrow As Long
Application.ScreenUpdating = False
CountComb = 0: lastrow = 1
For i = 1 To 10: For j = 1 To 10
Range("G" & lastrow).Value = Range("A" & i).Value & "/" & _
Range("B" & j).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
Next: Next
Application.ScreenUpdating = True
End Sub
see below. Note you need to add the reference Microsoft Scripting Runtime in Tools >> References. Change the Range("A1:A5") to either a dynamic named range or static range and the routine will handle the rest for you. It displays the results starting in G1 but you can also change this / make dynamic as an offset from the data range. Up to you.
Option Explicit
Option Base 1
Dim Data As Dictionary
Sub GetCombinations()
Dim dataObj As Variant
Dim returnData As Variant
Set Data = New Dictionary
Dim i As Double
dataObj = Range("A1:B5").Value2
' Group Data
For i = 1 To UBound(dataObj) Step 1
If (Data.Exists(dataObj(i, 2))) Then
Data(dataObj(i, 2)) = Data(dataObj(i, 2)) & "|" & dataObj(i, 1)
Else
Data.Add dataObj(i, 2), dataObj(i, 1)
End If
Next i
' Extract combinations from groups
returnData = CalculateCombinations().Keys()
Range("G1").Resize(UBound(returnData) + 1, 1) = Application.WorksheetFunction.Transpose(returnData)
End Sub
Private Function CalculateCombinations() As Dictionary
Dim i As Double, j As Double
Dim datum As Variant, pieceInner As Variant, pieceOuter As Variant
Dim Combo As New Dictionary
Dim splitData() As String
For Each datum In Data.Items
splitData = Split(datum, "|")
For Each pieceOuter In splitData
For Each pieceInner In splitData
If (pieceOuter <> pieceInner) Then
If (Not Combo.Exists(pieceOuter & "|" & pieceInner)) Then
Combo.Add pieceOuter & "|" & pieceInner, vbNullString
End If
End If
Next pieceInner
Next pieceOuter
Next datum
Set CalculateCombinations = Combo
End Function