Postup k-means:

Zkopírovat vzdálenosti do listu matice_vzdalenosti
Zkopírovat první dva sloupce (zařazení scénářů do klastrů) do sloupcu A a B v listu zarazeni_do_klastru

Makro Vsechno - doplni hodnoty
Makro Vypsani_reprezentantu - vypise do noveho listu reprezentanty

Sub Vypsani_reprezentantu()
'
'
'
   ActiveWorkbook.Sheets("zarazeni_do_klastru").Copy _
    After:=ActiveWorkbook.Sheets("zarazeni_do_klastru")
    Sheets("zarazeni_do_klastru (2)").Name = "vypsani_reprezentantu"
   Sheets("vypsani_reprezentantu").Select
   Range("A1").Select
   
   Columns("A:D").Select
    ActiveWorkbook.Worksheets("vypsani_reprezentantu").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("vypsani_reprezentantu").Sort.SortFields.Add Key:= _
        Range("B1:B1001"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("vypsani_reprezentantu").Sort.SortFields.Add Key:= _
        Range("C1:C1001"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("vypsani_reprezentantu").Sort
        .SetRange Range("A1:D1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
   q = 1

For i = 1 To 1000
If Cells(i, 2).Value = q Then
Cells(i, 5).Value = Cells(i, 1).Value
q = q + 1
End If
Next i
   
   For d = 1000 To 1 Step -1
  If StrComp("", Cells(d, 5).Value) = "0" Then
      Rows(d).Delete
  End If
Next d

   
End Sub


Sub Vsechno()


For j = 1 To 1001

For i = 1 To 1001

If Sheets("zarazeni_do_klastru").Range("A1:ALN1001").Cells(i, 1) = Sheets("data").Range("A1:ALN1001").Cells(j, 1) Then
      Sheets("zarazeni_do_klastru").Range("A1:ALN1001").Cells(i, 4) = Sheets("data").Range("A1:ALN1001").Cells(j, 1002)
      
       End If
       
Next i
Next j

prvku = Cells(Rows.Count, "A").End(xlUp).Row
shluku = Sheets("zarazeni_do_klastru").Cells(1000, 2).Value

h = 0
For j = 1 To shluku
    k = 0
For i = 1 To prvku
    If Sheets("zarazeni_do_klastru").Range("B1").Cells(i, 1) = j Then
        k = k + 1
    End If
    
Next i

For u = 1 To k
    t = 0
    For oo = 1 To prvku
        If Sheets("zarazeni_do_klastru").Range("A1").Cells(h + u, 1) = Sheets("matice_vzdalenosti").Range("A2").Cells(oo, 1) Then
            
        For r = 1 To k
        For o = 1 To prvku
        If Sheets("zarazeni_do_klastru").Range("A1").Cells(h + r, 1) = Sheets("matice_vzdalenosti").Range("B1").Cells(1, o) Then
            t = t + (Sheets("data").Range("B1").Cells(oo + 1, o))
            o = prvku
        End If
        Next o
        Next r
        End If
    Next oo
    Sheets("zarazeni_do_klastru").Range("C1").Cells(h + u, 1) = t
Next u
h = h + k
Next j


For q = 1 To shluku
Range("A1:L1001").Cells(q, 6) = q
Next q


For j = 1 To shluku
a = 0
For i = 1 To 1000

If Range("A1:L1001").Cells(i, 2) = j Then
      a = a + Cells(i, 4).Value
      
        
       End If

Next i
Range("A1:L1001").Cells(j, 7) = a

Next j



For j = 1 To shluku
a = 0
For i = 1 To 1000

If Range("A1:L1001").Cells(i, 2) = j Then
      a = a + Cells(i, 3).Value
      
        
       End If

Next i
Range("A1:L1001").Cells(j, 8) = a

Next j


For o = 1 To shluku
Range("A1:L1001").Cells(o, 10) = ((Cells(o, 7) - Cells(o, 8)) / Cells(o, 7))

Next o


q = 0

For u = 1 To shluku
q = q + Cells(u, 10).Value
Next u

Cells(shluku + 1, 10) = q

Cells(shluku + 3, 9) = "prumer"
Cells(shluku + 3, 10) = (Cells(shluku + 1, 10)) / shluku
Cells(shluku + 4, 9) = "minimum"

    
End Sub


--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

Postup hierarchické:
Zkopírovat do listu rozvrh_shlukovani rozvrh hierarchickoho shlukovani

Makro redukce_shluku - smaže shluky s málo členy a vypíše jejich rozdíly ve vzdálenostech

v listu rozvrh_shlukovani se zadává hodnota vzdálenosti, podle které se označují největší rozdíly

rozdíly se označí makrem Vybrani_vzdalenosti

po určení optimální vzdálenosti se dendogram ve Statistice uřeže v hodnotě vzdálenosti ze sloupce A

Tím vznikne rozdělení do shluků a pokračuje se obdobně jako u k-menas


Sub Vybrani_vzdalenosti()

Sheets("urceni_vzdalenosti").Select
Columns("B:B").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Top
        .Rank = Sheets("rozvrh_shlukovani").Range("G1").Value
        .Percent = False
    End With
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub


Sub redukce_shluku()
'
'
   ActiveWorkbook.Sheets("rozvrh_shlukovani").Copy _
    After:=ActiveWorkbook.Sheets("rozvrh_shlukovani")
    Sheets("rozvrh_shlukovani (2)").Name = "urceni_vzdalenosti"
   Sheets("urceni_vzdalenosti").Select
   Range("A1").Select
  
   For i = 1000 To 1 Step -1
  If StrComp("", Cells(i, "L").Value) = "0" Then
      Rows(i).Delete
  End If
Next i
  
    Sheets("urceni_vzdalenosti").Select
 Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=abs(RC[-1]-R[-1]C[-1])"
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B200")
    Range("B2:B200").Select
    Sheets("rozvrh_shlukovani").Select
    ActiveSheet.Range("F1").Select
    ActiveCell.FormulaR1C1 = "hodnota vzdalenosti"
    ActiveSheet.Range("G1").Select
    ActiveCell.FormulaR1C1 = "1"
    ActiveSheet.Range("E1:G1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
End Sub

