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
Related
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´ve an Excel file with 10 Columns. In columns 2, 3, 4 I have a number or a dash.
If the sum of these 3 cells is greater than 1, I need to replace that entire row with n rows that have only one of the columns with the value 1 but the other cells stay the same.
Example
1 - - #-> leave it as is
- 2 - #-> replace that row with 2 rows : - 1 - ; - 1 -
2 - 1 #-> replace that row with 3 rows : 1 - - ; 1 - - ; - - 1;
I managed to iterate from bottom up, but I´m having trouble storing a row in memory, manipulate it and insert below.
Sub Test()
Dim rng As Range
Dim count20, count40, count45, total, i As Integer
Set rng = Range("A3", Range("A3").End(xlDown))
For i = rng.Cells.count To 1 Step -1
count20 = 0
count40 = 0
count45 = 0
total = 0
count20 = Cells(rng.Item(i).Row, 10).Value
If count20 > 1 Then
total = total + count20
End If
count40 = Cells(rng.Item(i).Row, 11).Value
If count40 > 1 Then
total = total + count40
End If
count45 = Cells(rng.Item(i).Row, 12).Value
If count45 > 1 Then
total = total + count45
End If
If total <> 0 Then
MsgBox total
End If
Next i
End Sub
EDIT 2
I’ve provided alternative code based on your latest comment. It uses columns J-L (10-12) as the numeric cells to be changed, and columns A-I (1-9) and M-AD (13-30) as the cells with text to be preserved. As before, sheet 1 starting in row 3 is assumed, and you can change this to whatever you need.
Option Explicit
Sub testJtoL()
Dim LastRow As Long, i As Long, j As Long, c As Long, _
insertR As Long, TopRow As Long, BottomRow As Long
Dim b As Range
Dim ws As Worksheet
'*** This code is based your values being in Columns J-L (10-12) in sheet 1 ***
'Set sheet 1 as ws
Set ws = Sheet1
'Sheet1 column J is used here to get your last row
LastRow = ws.Cells(Rows.Count, 10).End(xlUp).Row
'*** This code is based your values starting in Row 3 ***
For c = LastRow To 3 Step -1
'Determine number of rows to insert based on sum of that row
insertR = Application.WorksheetFunction.Sum(Range(Cells(c, 10), Cells(c, 12))) - 1
If insertR = 0 Then GoTo skip
'STEP 1 insert the correct number of rows
With ws.Range(Cells(c + 1, 1), Cells(c + insertR, 30))
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
'STEP 2 fill the values into the correct number of rows
insertR = insertR + 1
With ws.Range(Cells(c, 1), Cells(c, 30))
.Resize(insertR, 30).Value = .Value
End With
TopRow = c
If insertR = 0 And c = 3 Then
BottomRow = c
Else
BottomRow = c + insertR - 1
End If
'STEP 3 replace all numbers with 1 or "-"
'Replace numbers in column J
If ws.Range(Cells(c, 10), Cells(c, 10)).Value = "-" Then GoTo SkipA
i = ws.Range(Cells(c, 10), Cells(c, 10)).Value
j = 1
For Each b In ws.Range(Cells(TopRow, 10), Cells(BottomRow, 10))
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
b.Offset(0, 2).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
Next b
SkipA:
'Replace numbers in column K
j = 1
For Each b In ws.Range(Cells(TopRow, 11), Cells(BottomRow, 11))
If b.Value = "-" Then GoTo SkipB
i = b.Value
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
SkipB:
Next b
'Replace numbers in column L
j = 1
For Each b In ws.Range(Cells(TopRow, 12), Cells(BottomRow, 12))
If b.Value = "-" Then GoTo SkipC
i = b.Value
If j <= i Then
b.Value = 1
Else
b.Value = "-"
End If
j = j + 1
SkipC:
Next b
skip:
Next c
End Sub
Hi I wanted to give numbering to the strings found in range of cells, can some one help in solving this
For example in a Excel sheet..Following data is present
Col1
A
B
C
D
B
E
A
F
I want the following result
Col1 Col2
A 1
B 1
C 1
D 1
B 2
E 1
A 2
F 1
A 3
B 3
Try the below code, let me know if this is what you required.
Sub test()
Dim i As Integer
i = Range("a65536").End(xlUp).Row
For k = 1 To i
If Cells(k, 2).Value = "" Then
a = Cells(k, 1).Value
For j = k + 1 To i
b = Cells(j, 1).Value
If a = b Then
temp = temp + 1
Cells(j, 2).Value = temp
End If
Next
temp = 0
End If
Next
End Sub
I have two columns in Excel with different values:
A 1
B 2
C 3
Now, I would need to pair each cell of first column with each cell of second column. So it would look like this:
A 1
A 2
A 3
B 1
B 2
B 3
C 1
C 2
C 3
Do you know how can I do this please?
Thank you heaps
With data in columns A and B try this short macro:
Sub MakeCombinations()
Dim Na As Long, Nb As Long
Dim i As Long, j As Long, K As Long
Dim rc As Long
K = 1
rc = Rows.Count
Na = Cells(rc, 1).End(xlUp).Row
Nb = Cells(rc, 2).End(xlUp).Row
For i = 1 To Na
For j = 1 To Nb
Cells(K, 3) = Cells(i, 1)
Cells(K, 4) = Cells(j, 2)
K = K + 1
Next j
Next i
End Sub
EDIT#1:
To do this without VBA, in C1 enter:
=INDEX(A:A,ROUNDUP(ROW()/COUNTA(B:B),0),1)
and copy down and in D1 enter:
=INDEX(B:B,MOD(ROW()-1,COUNTA(B:B))+1,1)
and copy down:
I modify Gary's answer with array. Not tested due to my Mac without Excel.
Sub MakeCombinations()
Dim Ary_a As Variant, Ary_b As Variant, Ary as Variant
Dim i As Long, j As Long
Ary_a = range(Cells(rows.count, 1).End(xlUp).Row, 1).value
Ary_b = range(Cells(rows.count, 2).End(xlUp).Row, 2).value
For i = lbound(ary_a) To ubound(ary_a)
For j = lbound(ary_b) To ubound(ary_b)
if not isarray(ary) then
redim ary(1, 0)
else
redim preserve ary(1, ubound(ary, 2)+1)
end if
ary(0, ubound(ary, 2)) = ary_a(i)
ary(1, ubound(ary, 2)) = ary_b(j)
Next j
Next i
cells(1, 4).resize(ubound(ary, 2)+1, ubound(ary, 1)+1).value = application.transpose(ary)
End Sub
I'm working on a google spreadsheet with something like this (it's a single column):
1
2
3,4
5
6-9
15
18
3,4 is 3 and 4
6-9 is 6, 7, 8 and 9
On another sheet I made a standard 1-100 list and I have to find a way to "mark" the numbers that appears or that are included on the previous list, like this.
1 YES
2 YES
3 YES
4 YES
5 YES
6 YES
7 YES
8 YES
9 YES
10 NO
11 NO
12 NO
13 NO
14 NO
15 YES
I can easily find the simple unique numbers by using in cell B1:
=IF((COUNTIF(list!$A$1:$A$100,VALUE(A1))=1),"YES","NO")
I can even find what the first number is:
=IFERROR(LEFT(list!$A$1:$A$100,(SEARCH(",",list!$A$1:$A$100)-1)),IFERROR(LEFT(list!$A$1:$A$100,(SEARCH("-",list!$A$1:$A$100)-1)),list!$A$1:$A$100))
But I can't expand the search to include the numbers between the "x-y" or after the comma in "x,y".
I've tried AND("bigger than 1st number","smaller than 2nd number") but I haven't found a way to extract the second number.
Any suggestion?
Here is a macro that will work for an excel spreadsheet. You can adapt it to Google apps script:
Sub IsItThere()
Dim s1 As Worksheet, s2 As Worksheet, N As Long
Dim v As Variant, i As Long, ary()
Dim N1 As Long, N2 As Long, j As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Collection
Set c = New Collection
For i = 1 To N
v = Cells(i, 1).Value
If InStr(1, v, ",") > 0 Then
c.Add CLng(Split(v, ",")(0))
c.Add CLng(Split(v, ",")(1))
ElseIf InStr(1, v, "-") > 0 Then
N1 = CLng(Split(v, "-")(0))
N2 = CLng(Split(v, "-")(1))
For j = N1 To N2
c.Add j
Next j
Else
c.Add CLng(v)
End If
Next i
ReDim ary(1 To c.Count)
For i = 1 To c.Count
ary(i) = c.Item(i)
Next i
s2.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
For j = 1 To c.Count
If v = ary(j) Then
Cells(i, 2).Value = "YES"
GoTo pass
End If
Next j
Cells(i, 2).Value = "NO"
pass:
Next i
End Sub