CrearSociograma es una macro para excel 2003 que toma una hoja con las columnas Elector, Elegido1, Elegido2, Rechazado1, Rechazado2, Elecciónpercibida1, ElecciónPercibida2, Rechazopercibido1, Rechazopercibido2 y genera autoformas que representan las diversas elecciones.

Attribute VB_Name = "CrearSociograma"
'Toma una hoja con el formato
'Elector, Elegido1, Elegido2, Rechazado1, Rechazado2, Elecciónpercibida1, ElecciónPercibida2, Rechazopercibido1, Rechazopercibido2
'y genera un sociograma.
'
Sub CrearSociograma()
Dim hoja As Worksheet
Dim grafico As Worksheet
 
Set hoja = ThisWorkbook.ActiveSheet
Set grafico = ThisWorkbook.Sheets.Add
Dim sh(50) As Shape
Dim elector As String, elegido As String
Dim forma1 As Shape, forma2 As Shape, conector As Shape
 
 
Dim rang As Range
 
Debug.Print "espere"
Dim tx As String
'1: Crear los óvalos con los nombres
For f = 1 To UBound(sh)
    tx = hoja.Range("A" & Trim("" & f + 1)).Text
    If tx = "" Then Exit For
    Debug.Print tx
    Set sh(f) = grafico.Shapes.AddShape(msoShapeOval, 100 * Int(f / 10), 100 * (f Mod 10), 50, 50)
    sh(f).Name = tx
    sh(f).TextFrame.Characters.Insert (tx)
    sh(f).AlternativeText = tx
 
 
Next f
 
'GoTo Rechazo
Eleccion:
 
'2: Conectar cada elector con sus elecciones 1 y 2
For f = 1 To UBound(sh)
    elector = hoja.Range("A" & Trim("" & f + 1)).Text
    If elector = "" Then Exit For
    Set forma1 = grafico.Shapes(elector)
    'Primera elección
    elegido = hoja.Range("B" & Trim("" & f + 1)).Text
    If (elegido <> "") And (elegido <> "--") Then
        conectarforma grafico, forma1, grafico.Shapes(elegido), RGB(0, 255, 0), msoArrowheadTriangle, 5
    End If
    'Segunda elección
    elegido = hoja.Range("C" & Trim("" & f + 1)).Text
    If (elegido <> "") And (elegido <> "--") Then
        conectarforma grafico, forma1, grafico.Shapes(elegido), RGB(0, 255, 0), msoArrowheadTriangle, 5
    End If
Next f
 
Rechazo:
'2: Conectar cada elector con sus elecciones 1 y 2
For f = 1 To UBound(sh)
    elector = hoja.Range("A" & Trim("" & f + 1)).Text
    If elector = "" Then Exit For
    Set forma1 = grafico.Shapes(elector)
    'Primer rechazo
    elegido = hoja.Range("D" & Trim("" & f + 1)).Text
    If (elegido <> "") And (elegido <> "--") Then
        conectarforma grafico, forma1, grafico.Shapes(elegido), RGB(255, 0, 0), msoArrowheadTriangle, 5
    End If
    'Segundo rechazo
    elegido = hoja.Range("E" & Trim("" & f + 1)).Text
    If (elegido <> "") And (elegido <> "--") Then
        conectarforma grafico, forma1, grafico.Shapes(elegido), RGB(255, 0, 0), msoArrowheadTriangle, 5
    End If
 
Next f
 
 
 
End Sub
'Crea una unión entre dos formas.
'  forma1 (Shape): Primera forma
'  forma2 (Shape): Segunda forma
'  RGBColor (long): Color (=RGB(X,Y,Z))
'  Arrowhead (msoarrowheadstyle): Forma de la flecha.
'  Weight (single): Grosor.
Sub conectarforma(grafico As Worksheet, forma1 As Shape, forma2 As Shape, RGBColor As Long, arrowhead As MsoArrowheadStyle, weight As Single)
Dim conector As Shape
    Set conector = grafico.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)
    With conector.ConnectorFormat
        .BeginConnect forma1, 1
        .EndConnect forma2, 1
        conector.RerouteConnections
    End With
    'Color de línea, etc etc
    With conector.Line
        .BeginArrowheadStyle = arrowhead
        .ForeColor.RGB = RGBColor
        .weight = weight
    End With
 
End Sub