I am trying to produce a co-occurrence matrix in an Excel File. My data looks like this:
person1 A
person1 B
person2 A
person2 C
person2 D
person3 A
person3 B
person4 A
person4 C
...
But what I need is essentially a co-occurrence matrix that looks like this (it counts how often any of the combos between A-D occured):
A B C D
A 0 2 2 1
B 2 0 0 0
C 2 0 0 1
D 1 0 1 0
I unfortunately cannot find a useful VBA or Macro or any other approach (I am a beginner with VBA) - so if you have any idea how I could do this, please share.
I tried doing a Pivot but I cannot put the second column of the data on both of the two axis.
In R I would do this with crossprod() but I cannot get the data out of a save environment and cannot install R there either...
Many thanks!
Use a dictionary with column B as key, collection of column A as value. Iterate the combinations and count the matches. Results written to Sheet2.
Option Explicit
Sub CoOccurence()
Dim dict As Object, k, ar, m, v1, v2
Set dict = CreateObject("Scripting.Dictionary")
Dim lastrow As Long, i As Long, j As Long
Dim a As String, b As String
With Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
a = .Cells(i, "A")
b = .Cells(i, "B")
If Not dict.exists(b) Then
dict.Add b, New Collection
End If
dict(b).Add a
Next
End With
' results
ar = dict.keys
i = dict.Count
ReDim m(1 To i, 1 To i)
With Sheet2
For i = 1 To UBound(m)
' headers
.Cells(1, i + 1) = ar(i - 1)
.Cells(i + 1, 1) = ar(i - 1)
' counts
For j = 1 To UBound(m, 2)
a = ar(i - 1)
b = ar(j - 1)
m(i, j) = 0
If a <> b Then
For Each v1 In dict(a)
For Each v2 In dict(b)
If v1 = v2 Then m(i, j) = m(i, j) + 1
Next
Next
End If
.Cells(i + 1, j + 1) = m(i, j)
Next
Next
End With
MsgBox "Done"
End Sub
I modified this vba code to generate combinations of six from 10 groups of pairs where only one number of a pair is used for each combination. but I can't get exactly what i want, and there many repetitions of the same combinations and some numbers are not even used in combinations. Can I get a little help to fix this code, please? thanks.
Here is the vba:
Sub Combs()
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim h As Long
Dim j As Long
Dim k As Long
Dim i As Long
Dim grp
grp = Range("B1:C10").Value
Dim arr(1 To 1025, 1 To 10) As Long
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
For g = 1 To 2
For h = 1 To 2
For j = 1 To 2
For k = 1 To 2
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
arr(i, 7) = grp(7, g)
arr(i, 8) = grp(8, h)
arr(i, 9) = grp(9, j)
arr(i, 10) = grp(10, k)
Next k
Next j
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Here is a sample data:
Group1 1 2
Group2 3 4
Group3 5 6
Group4 7 8
Group5 9 10
Group6 11 12
Group7 13 14
Group8 15 16
Group9 17 18
Group10 19 20
I'm guessing your want to randomly select 6 from 10
Sub Combos()
Dim i As Integer, j As Integer, k As Integer, n As Integer
Dim c As Integer, digit As Integer
Dim b As String, bb As String
Dim grp, arr(1 To 1025, 1 To 10) As Long, cols
' group data
grp = Range("B1:C10").Value
For j = 0 To 31
b = CStr(WorksheetFunction.Dec2Bin(j, 5))
For k = 0 To 31
bb = b & CStr(WorksheetFunction.Dec2Bin(k, 5))
i = j * 32 + k + 1
' select 6 of the 10 columns
cols = SixFromTen
Range("V" & i + 1) = Join(cols, ",") ' show combo
For c = 0 To 5
n = cols(c) '
'Debug.Print j, k, n
digit = CInt(Mid(bb, n, 1)) ' binary digit
arr(i, c + 1) = grp(n, digit + 1)
Next
Next
Next
Range("O2").Resize(1025, 6).Value = arr
MsgBox "Done"
End Sub
Function SixFromTen() As Variant
Dim num As New Collection, ar(5) As String
Dim i As Integer, n As Integer
Dim a As Integer, b As Integer, tmp As Integer
For n = 1 To 10
num.Add n
Next
For i = 0 To 5
n = 1 + Int(Rnd() * num.Count)
ar(i) = num(n)
num.Remove n
Next
'bubble sort
For a = 0 To 4
For b = a + 1 To 5
If CInt(ar(a)) > CInt(ar(b)) Then
tmp = ar(a)
ar(a) = ar(b)
ar(b) = tmp
End If
Next
Next
SixFromTen = ar
End Function
Alternatively remove 4 from 10 to leave 6 in correct order.
Function SixFromTen() As Variant
Dim num As New Collection, ar(5) As String
Dim i As Integer, n As Integer
For n = 1 To 10: num.Add n: Next
' remove 4
For i = 0 To 3
n = 1 + Int(Rnd() * num.Count)
num.Remove n
Next
For i = 0 To 5: ar(i) = num(i + 1): Next
SixFromTen = ar
End Function
As AcsErno pointed out, the issue is that your program is generating ten columns of digits but the output is only for six columns. Removing four columns results in many repeated combinations because the unique part has been removed in those four columns.
The solution is to only generate six columns, therefore allowing each of them to remain unique. I have rewritten your program to only generate six columns:
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:C6").Value
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Note: The upper bound of the array can be reduced from 1025 since we are no longer using as many rows. If you require additional combinations, you can add a third number to any of the pairs.
An Example:
How to input the combination numbers
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:E6").Value 'Increasing the width
For a = 1 To 2
For b = 1 To 2
For c = 1 To 4 'Changed from 2 to 4
For d = 1 To 4 'Changed from 2 to 4
For e = 1 To 4 'Changed from 2 to 4
For f = 1 To 4 'Changed from 2 to 4
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
After reading your comments I think I better understand what you are looking for. It sounds like you want the combination to be a subset of six numbers from a set of ten. And each of those ten numbers is one of two values. If I understand that correctly, your issue is that you are having trouble iterating the six columns from the set of ten.
I replaced four of your For Loops with one that loops through the columns instead:
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, alt As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:c10").Value
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
For alt = 0 To 4
'Interating the used section through the full 10 columns.
'Only six columns are used in each combo, but we change which six are used from those 10
i = i + 1
arr(i, 1) = grp(1 + alt, a)
arr(i, 2) = grp(2 + alt, b)
arr(i, 3) = grp(3 + alt, c)
arr(i, 4) = grp(4 + alt, d)
arr(i, 5) = grp(5 + alt, e)
arr(i, 6) = grp(6 + alt, f)
Next alt
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Note: This produces 320 unique combinations. This is not all possible combinations with these number pairs, for a more complete list, you could add in additional arrays with column positions swapped.
I am trying to copy column B into column E based off of a criteria in C. However, I can't seem to figure out how to copy the data into the matching row .
For example , I would like it be executed like this { matching with the corresponding text in column B to E if column (C=x)}
Column > A | B | C | D | E
A X A
B Y
C X C
Here's what I have
Dim x As Integer
Dim textSG As String
Dim erow As Long
x = 3
erow = 0
Do while Worksheet.Cell(x, 3) <> ""
If InStr ((Worksheet.Cells(x, 3)),"X" > 0 Then
textSG = Worksheet.Cells(x, 2)
erow = erow + 3
Worksheet.Cells(erow, 5) = textSG
End if
x = x + 1
Loop
Please try this code. I think it does what you intend.
Dim R As Long
For R = 3 To Cells(Rows.Count, 3).End(xlUp).Row
' case insensitive comparison
If StrComp(Trim(Cells(R, 3).Value), "x", vbTextCompare) = 0 Then
Cells(R, 5).Value = Cells(R, 2).Value
End If
Next R
Let's say I have a list of numbers
Column A
1
2
3
4
5
6
7
and I want to move these numbers to B, C, D. evenly like
Column B: 1,2,3, Column C: 4,5, Column D: 6,7
The list of numbers always changes.
Sub Macro1()
'
' Macro1 Macro
'
'
k = 0
r = Range("A1").End(xlDown).Row
For i = 1 To r
j = 2
If k = 0 Then
k = 1
End If
If i <= (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
If (i + 1) > (r / 3) Then
k = 0
End If
End If
j = 3
If i > r / 3 And i <= 2 * (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
If (i + 1) > 2 * (r / 3) Then
k = 0
End If
End If
j = 4
If i > 2 * (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
End If
Next i
End Sub
I'm trying to create a permutation list in excel for 6 numbers, each in their own columnA-F and each number is from 1-38. when i run the VBA i find that the permutations far exceed rows 1048576 available in excel, so therefore the VBA ends at that point. i want a VBA that when the rows reach 1048576 on whatever sheet and the permutation isnt finished it will just create a new sheet and continue where it stopped on the previous sheet and automatically create sheets until the permutation ends. i've searched passed questions but none found to help. Any expert help would be greatly appreciated.
Code:
Sub Perm()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
n = 1
For a = 1 To 38
For b = 1 To 38
For c = 1 To 38
For d = 1 To 38
For e = 1 To 38
For f = 1 To 38
Cells(n, 1).Value = a
Cells(n, 2).Value = b
Cells(n, 3).Value = c
Cells(n, 4).Value = d
Cells(n, 5).Value = e
Cells(n, 6).Value = f
n = n + 1
Next f
Next e
Next d
Next c
Next b
Next a
End Sub
This should do it for you:
Sub Perm()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
Dim n As Long
Dim maxRows As Long
Dim sheetNumber As Integer
Dim loopCounter As Integer
maxRows = 1048576
loopCounter = 38
sheetNumber = 1
n = 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
Application.ScreenUpdating = False
For a = 1 To loopCounter
For b = 1 To loopCounter
For c = 1 To loopCounter
For d = 1 To loopCounter
For e = 1 To loopCounter
For f = 1 To loopCounter
Cells(n, 1).Value = a
Cells(n, 2).Value = b
Cells(n, 3).Value = c
Cells(n, 4).Value = d
Cells(n, 5).Value = e
Cells(n, 6).Value = f
If n = maxRows Then
sheetNumber = sheetNumber + 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
n = 0
End If
n = n + 1
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
End Sub
This will create a sheet called "Sheet-1" and fill it up down to row 1048576.
Then it will create a new sheet called "Sheet-2" and repeat until that is full, etc.
It is best to disable ScreenUpdating for intensive cell writing as it will make a big reduction to the running time.
Good luck, as it will probably take awhile. As the other poster says, it will need nearly 3000 worksheets. Hopefully you have enough memory on your machine.