So let me explain what I'm trying to do. I have a list of events with two columns: Event ID and Guests. In the Guests field I have the email of every participant of that specific event separated by a comma. Each event has a different number of participants. What I need is to list all possible combinations of guests for each event. It looks something like this:
Assume in one meeting the participants are A, B, C, D
This represents the following unique 1:1 connections
AB
AC
AD
BC
BD
CD
Do any of you know a code that could get to this output?
#Gary's Student Thanks!
This is what I have, but it's not working properly.
Excel table
Sub test1()
Set l1 = Worksheets("Sheet1").Range("A1:AZ10000").Find("Event ID", lookat:=xlPart) 'Location of event id field
Set l2 = Worksheets("Sheet1").Range("A1:AZ10000").Find("Participants123", lookat:=xlPart) 'Location of guests field
Last = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Double
Dim l As Double
l = l2.Row + 1
For i = 1 To Last
last1 = Sheet1.Cells(l, l2.Column).End(xlToRight).Column
c = Application.Combin(last1 - 3, 2)
Rows(l + 1 & ":" & l + c - 1).Insert
'Dim N As Long, i As Long, j As Long, K As Long
N = last1
K = l
For b = 4 To N - 1
For j = b + 1 To N
Cells(K, 2).Value = Cells(l, b).Value
Cells(K, 3).Value = Cells(l, j).Value
K = K + 1
Next j
Next b
l = l + c
Next i
End Sub
! (http://imgur.com/72nW9uR)
Place the names in column A and run something like this:
Sub dural()
Dim N As Long, i As Long, j As Long, K As Long
N = 4
K = 1
For i = 1 To N - 1
For j = i + 1 To N
Cells(K, 2).Value = Cells(i, 1).Value & Cells(j, 1).Value
K = K + 1
Next j
Next i
End Sub
This assumes that you only need pairs so ABC is not considered. Also assumes that AB and BA are the same.
Related
I have a list of 1000+ names in a single column in excel where the names repeat occasionally. I am trying to count how many times each name occurs. This is what I have currently and it populates the desired sheet but it seems to mess up when counting the number of times the names show up. Anything helps!
m = 2
n = 1
person = Worksheets("Sheet1").Cells(m, 6).Value
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
For i = 0 To Total_Tickets
person = Worksheets("Sheet1").Cells(m, 6).Value
y = 1
d = 0
Do While d <= i
comp = Worksheets("Sorted_Data").Cells(y, 2).Value
x = StrComp(person, comp, vbTextCompare)
If x = 0 Then
Worksheets("Sorted_Data").Cells(n - 1, 3).Value = Worksheets("Sorted_Data").Cells(n - 1, 3).Value + 1
m = m + 1
d = 10000
ElseIf x = 1 Or x = -1 Then
If comp = "" Then
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
d = 10000
End If
y = y + 1
d = d + 1
End If
Loop
Next i
You're managing a lot of counters there, and that makes the logic more difficult to follow.
You could consider something like this instead:
Sub Tester()
Dim wsData As Worksheet, wsList As Worksheet, arr, m, i As Long, nm
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsList = ThisWorkbook.Sheets("Sorted_Data")
'grab all the names in an array
arr = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1) 'loop over the array
nm = arr(i, 1) 'grab the name
m = Application.Match(nm, wsList.Columns("A"), 0) 'existing name on the summary sheet?
If IsError(m) Then
'name was not found: add it to the summary sheet
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = nm
m = .Row
End With
End If
With wsList.Cells(m, "B")
.Value = .Value + 1 'update the count
End With
Next i
End Sub
I want to loop each number in column A through column B.
If there is a match, that number to be looped through column C.
If there is a match, I want the results to be returned in columns E and F.
Each column will have a variable amount of rows. There can also be multiple results.
In my example the number 1 from column A is looped through column B. If a match is found 1 is now looped through column C. If there is a match then columns E and F = C and D.
Example
If your data is arranged like bellow picture,then the code would be like this.
Sub test()
Dim vDB1, vDB2, vDB3, vR()
Dim i As Long, j As Long, k As Long, n As Long
vDB1 = Range("a2", Range("a" & Rows.Count).End(xlUp))
vDB2 = Range("b2", Range("b" & Rows.Count).End(xlUp))
vDB3 = Range("c2", Range("d" & Rows.Count).End(xlUp))
Range("e2:f2").Resize(Rows.Count - 1) = Empty
For i = 1 To UBound(vDB1, 1)
For j = 1 To UBound(vDB2, 1)
If vDB1(i, 1) = vDB2(j, 1) Then
For k = 1 To UBound(vDB3, 1)
If vDB1(i, 1) = vDB3(k, 1) Then
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = vDB3(k, 1)
vR(2, n) = vDB3(k, 2)
End If
Next
End If
Next j
Next i
If n > 0 Then
Range("e2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End If
End Sub
Here is a code that should do the job. But if Tab1/Tab2 values are not unique then it might do a lookup multiple times. For example if there was 1 in place of 9 in Tab 2 it would show the row with 1 twice in tab 4. If you want to avoid that you will need to modify my code
Set tab1_list = Sheets("sheet1").Range("B6:B10")
Set tab2_list = Sheets("sheet1").Range("C6:C10")
Set tab3_list_lookup = Sheets("sheet1").Range("E6:E10")
Set Tab3_List_value = Sheets("sheet1").Range("F6:F10")
Set output_location = Sheets("sheet1").Range("H6")
For Each cell1 In tab1_list
For Each cell2 In tab2_list
If cell1.Value = cell2.Value Then
For index_no = 1 To tab3_list_lookup.Cells.Count
If tab3_list_lookup.Cells(index_no).Value = cell2.Value Then
output_location.Value = tab3_list_lookup.Cells(index_no).Value
output_location.Offset(0, 1) = Tab3_List_value.Cells(index_no).Value
Set output_location = output_location.Offset(1, 0)
End If
Next index_no
End If
Next cell2
Next cell1
I am trying to run a loop that looks for a value in a column and if it is found then another value is entered in the cell to the right of it.
m = 2
h = 1
Cells(m, 23).Select
Do
Cells(m, 23).Select
If ActiveCells <> " " Then
Cells(m, 24) = "Test"
End If
If InStr(Cells(m, 24).Text, "-") Then
h = h + 1
End If
m = m + 1
What I am finding is the script runs and does not seem to identify when the cell contains the word "Region". It is just skipping over as if the cell is empty.
Still pretty new to VBA's so this may or may not be an easy fix.
Thank you!
Try this:
Dim lr As Long
Dim m As Long: m = 2
Dim h As Long: h = 1
'Properly reference objects
With Sheets("YourActualSheetName")
'To add better control, identify boundaries of your loop,
'so find the last row that contain data.
lr = .Columns(23).Find(What:="*", _
After:=.Cells(1, 23), _
SearchDirection:=xlPrevious).Row
Do
'You can use one liner If's for some cases like this one
If .Cells(m, 23) = "Region" Then .Cells(m, 24) = "Type"
If InStr(.Cells(m, 24), "-") <> 0 Then h = h + 1
m = m + 1
Loop Until m > lr
End With
Edit1: As stated in the comments
Dim m As Long: m = 2
Dim h As Long: h = 1
With Sheets("YourActualSheetName")
Do
If .Cells(m, 23) = "Region" Then .Cells(m, 24) = "Type"
If InStr(.Cells(m, 24), "-") <> 0 Then h = h + 1
m = m + 1
Loop Until h = 9
End With
In the tab Paste New IDs Here column A, starting at row 2, has a list of unique IDs used to identify a person. There are thirty unique ID numbers.
In the Raw Export tab, there's a bunch of raw data, where column B, starting at row 2, has all the IDs for 200+ people.
I am putting a list of ID numbers in Paste New IDs Here and pulling the entire row associated with that ID number into Test. Therefore, only rows that have ID numbers specified in the Paste New IDs Here sheet will be copied into Test.
Only ten rows (out of the thirty) are being generated.
Do I need another loop?
Sub ExtractID()
Set i = Sheets("Raw Export")
Set e = Sheets("Test")
Set p = Sheets("Paste New IDs Here")
Dim d
Dim j
Dim k
d = 1
j = 2
k = 2
Do Until IsEmpty(i.Range("B" & j))
If i.Range("B" & j) = p.Range("A" & k) Then
d = d + 1
k = k + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
You need to add an inner loop over k:
Do Until IsEmpty(i.Range("B" & j))
Do Until isEmpty(p.Range("A"&k))
If i.Range("B" & j) = p.Range("A" & k) Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
k = k + 1
Loop
k=2
j = j + 1
Loop
I'm working on a project where I need to combine 6 keywords to the maximum number of combinations. After this is done, I have to transform these combinations to a form of binary.
example:
Word1 = 100000
Word2 = 010000
Word3 = 001000
Word4 = 000100
Word5 = 000010
Word6 = 000001
And a combination could be: (Word1 Word2 Word5) = 110010
My 6 keywords are in column A2:A7.
If this could be done in VBA, it would make my job a lot easier.
Acording to basic math, 6 entries would combine to 64 combinations. I don't need the "blank" combination, why it'll total 63 combinations.
I'm fairly new to coding and have only worked in VBA for a couple of weeks, so I'm hoping that there might be a specialist out there that could help me with this problem.
Update!
This is what I have written so far. It only combines the words once:
Sub combinations()
Dim i As Long, j As Long, k As Long, l As Long, n As Long, m As Long, lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For j = i + 1 To lr
For k = j + 1 To lr
For l = k + 1 To lr
For n = l + 1 To lr
For m = n + 1 To lr
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) = .Cells(i, 1).Value & " " & .Cells(j, 1).Value & " " & .Cells(k, 1).Value & " " & .Cells(l, 1).Value & " " & .Cells(n, 1).Value & " " & .Cells(m, 1).Value
Next m
Next n
Next l
Next k
Next j
Next i
End With
End Sub
Regards,
Emil
It would be easier to begin with the bitmap representation (BTW it would be best to avoid calling those "binary")
Dim a, b, c, d, e, f, i
i = 1
For a = 0 To 1
For b = 0 To 1
For c = 0 To 1
For d = 0 To 1
For e = 0 To 1
For f = 0 To 1
Cells(i, 1).Value = "'" & a & b & c & d & e & f
i = i + 1
Next f
Next e
Next d
Next c
Next b
Next a