Sub VennDiagram_3Arr()
v1 = Array("a", "b", "c", "d", "n", "x")
v2 = Array("a", "b", "e", "x", "f", "m")
v3 = Array("a", "x", "e", "c", "g", "n")
'SECTION 1 CREATE ARRAYS #####
Dim cCAll As New Collection
Dim c1 As New Collection
Dim c2 As New Collection
Dim c3 As New Collection
Dim c12 As New Collection
Dim c13 As New Collection
Dim c23 As New Collection
Dim c123 As New Collection
Dim nc1 As New Collection
Dim nc2 As New Collection
Dim nc3 As New Collection
For Each v In v1
cCAll.Add v
c1.Add v
Next
For Each v In v2
cCAll.Add v
c2.Add v
Next
For Each v In v3
cCAll.Add v
c3.Add v
Next
Dim vV123
ReDim vV123(1 To cCAll.Count)
Dim x As Long
x = 1
For Each c In cCAll
vV123(x) = c
x = x + 1
Next
'MsgBox Join(vV123, ",")
Dim fg1 As Boolean, fg2 As Boolean, fg3 As Boolean
Dim fg1_1 As Boolean, fg2_1 As Boolean, fg3_1 As Boolean
'dictionary METHOD:

'based from url
'http://www.mrexcel.com/forum/excel-questions/636537-%5Bvisual-basic-applications%5D-count-number-occurances-array.html
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For x = LBound(vV123) To UBound(vV123)
If dict.exists(vV123(x)) Then
dict.Item(vV123(x)) = dict.Item(vV123(x)) + 1
Else
dict.Add vV123(x), 1
End If
Next x

For Each v In dict.keys
fg1 = False: fg2 = False: fg3 = False
fg1_1 = False: fg2_1 = False: fg3_1 = False
If dict.Item(v) = 3 Then c123.Add v
If dict.Item(v) = 2 Then
For Each vv In c1
If vv = v Then fg1 = True
Next
For Each vv In c2
If vv = v Then fg2 = True
Next
For Each vv In c3
If vv = v Then fg3 = True
Next
If fg1 = True And fg2 = True Then c12.Add v
If fg1 = True And fg3 = True Then c13.Add v
If fg3 = True And fg2 = True Then c23.Add v
End If
If dict.Item(v) = 1 Then
For Each vv In c1
If vv = v Then fg1_1 = True
Next
For Each vv In c2
If vv = v Then fg2_1 = True
Next
For Each vv In c3
If vv = v Then fg3_1 = True
Next
If fg1_1 = True Then nc1.Add v
If fg2_1 = True Then nc2.Add v
If fg3_1 = True Then nc3.Add v
End If
Next v

If c123.Count = 0 Then ReDim v123(1 To 1): v123(1) = "": GoTo nnext1
ReDim v123(1 To c123.Count)
t = 1
For Each v In c123
v123(t) = v
t = t + 1
Next

nnext1:
If c12.Count = 0 Then ReDim nv12(1 To 1): nv12(1) = "": GoTo nnext2
ReDim nv12(1 To c12.Count)
t = 1
For Each v In c12
nv12(t) = v
t = t + 1
Next
nnext2:

If c13.Count = 0 Then ReDim nv13(1 To 1): nv13(1) = "": GoTo nnext3
ReDim nv13(1 To c13.Count)
t = 1
For Each v In c13
nv13(t) = v
t = t + 1
Next
nnext3:

If c23.Count = 0 Then ReDim nv23(1 To 1): nv23(1) = "": GoTo nnext4
ReDim nv23(1 To c23.Count)
t = 1
For Each v In c23
nv23(t) = v
t = t + 1
Next
nnext4:

If nc1.Count = 0 Then ReDim nv1(1 To 1): nv1(1) = "": GoTo nnext5
ReDim nv1(1 To nc1.Count)
t = 1
For Each v In nc1
nv1(t) = v
t = t + 1
Next
nnext5:

If nc2.Count = 0 Then ReDim nv2(1 To 1): nv2(1) = "": GoTo nnext6
ReDim nv2(1 To nc2.Count)
t = 1
For Each v In nc2
nv2(t) = v
t = t + 1
Next
nnext6:

If nc3.Count = 0 Then ReDim nv3(1 To 1): nv3(1) = "": GoTo nnext7
ReDim nv3(1 To nc3.Count)
t = 1
For Each v In nc3
nv3(t) = v
t = t + 1
Next
nnext7:
'END SECTION 1 #####
'

'SECTION 2 CREATE SHAPES IN A NEW SHEET #####

Dim wsName
wsName = "Venn_Arr3"
Application.DisplayAlerts = False
For Each sh In Sheets
'If sh.Name Like "*VennArray3*" Then sh.Delete
If sh.Name = wsName Then sh.Delete
Next
Application.DisplayAlerts = True
Sheets.Add
ActiveSheet.Name = wsName
'##################
Dim w1 As Double
Dim h1 As Double
 w1 = 13.57 / 5
 h1 = 71 / 5
 With ActiveSheet
 .Cells.ColumnWidth = w1
 .Cells.RowHeight = h1
End With
 ActiveWindow.DisplayGridlines = False
'################
Dim r As Range
Set r = [A1]
Dim nDb As Double
nDb = 200

Dim vColor
vColor = Array(vbRed, vbGreen, vbBlue)
Dim vX
vX = Array(0, nDb * 0.5, nDb * 0.25)
Dim vY
vY = Array(0, 0, nDb * 0.5)
Dim i As Long
For i = 0 To UBound(vColor)
With ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left + vX(i), r.Top + vY(i), nDb, nDb)
.LockAspectRatio = msoTrue
With .Line
.Visible = msoTrue
.Weight = 2
.ForeColor.RGB = vColor(i)
End With
With .Fill
.Visible = msoTrue
.ForeColor.RGB = vColor(i)
.Transparency = 0.75
.Solid
End With
End With
Next

Dim vCells
vCells = Array("c4:e8", "h4:j6", "m4:o8", "e11:f13", "h9:j11", "L11:M13", "H16:J19")
Dim vText
vText = Array(Join(nv1, ","), Join(nv12, ","), Join(nv2, ","), Join(nv13, ","), Join(v123, ","), Join(nv23, ","), Join(nv3, ","))

For i = 0 To UBound(vCells)
With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Range(vCells(i)).Left, Range(vCells(i)).Top, Range(vCells(i)).Width, Range(vCells(i)).Height)
.TextFrame2.TextRange.Font.Size = 12
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.TextFrame2.TextRange.Characters.Text = vText(i)
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
End With
Next
ActiveSheet.Shapes.SelectAll
Selection.Group
With Selection.ShapeRange
.IncrementLeft 20
.IncrementTop 20
End With
[A1].Select
End Sub