Sub PraceSOznacenymPolem()
'Selection.Clear vyčistí označenou oblast
'Selection=10 nahradí všude value desítkou
'Selection.Rows.Count počet řad
'Selection.Columns.Count počet sloupců
'Selection.Count počet buněk ve výběru
End Sub
Sub selectionSoucet()
Dim soucet As Double, i As Double
For i = 1 To Selection.Count 'For Each c In Selection jde taky, ale nejde měnit buńky
    soucet = soucet + Selection.Cells(i)
Next i
MsgBox soucet
'Program zjistí součet hodnot označených buněk
End Sub
'Rem kopirovani selection na List2, list bude aktivni, A1 aktivní
Sub selectionCopy()
    Selection.Copy Worksheets("List2").Cells(2, 2)
    Worksheets("List2").Activate 'List2 se stane aktivním
    Cells(1, 1).Activate
End Sub

'Rem přesunutí selection na list2
Sub selectionCut()
    Selection.Cut Worksheets("List2").Cells(2, 2)
End Sub
'Makro se zeptá zda má danou oblast přesunout nebo kopírovat
'následně volbu provede a do daného listu od buňky A1.

Sub prp()
Dim volba As Double
Dim adresa As String
adresa = InputBox("Zadej list")
volba = InputBox("1. kopírovat 2. přesunout")
    If (volba = 1) Then
        Selection.Copy Worksheets(adresa).Cells(1, 1)
        Worksheets(adresa).Activate
        Cells(1, 1).Activate
    ElseIf (volba = 2) Then
        Selection.Cut Worksheets(adresa).Cells(1, 1)
    End If
End Sub
'využití funkce listu
'min a max budou červeně
Sub fceExc9()
Dim max As Double, min As Double
max = Application.WorksheetFunction.max(Selection)
min = Application.WorksheetFunction.min(Selection)
MsgBox ("Max:" & max)
MsgBox ("Min:" & min)
For i = 1 To Selection.Count
    If (Selection.Cells(i) = max Or Selection.Cells(i) = min) Then
        Selection.Cells(i).Font.ColorIndex = 3
    End If
Next i


End Sub
'Všechny nadprůměrné hodnoty vložte do souboru
'na název souboru se zeptejte
Sub programeme()
Dim soubor As String, hodnota As String
soubor = InputBox("Zadej název souboru")
Dim prum As Double
prum = Application.WorksheetFunction.Average(Selection)
For i = 1 To Selection.Count
    If (Selection.Cells(i) > prum) Then
        hodnota = hodnota & Selection.Cells(i) & ";"
    End If
Next i

cesta = Application.GetSaveAsFilename + "txt"
Open cesta For Output As #1
Print #1, hodnota
Close #1
End Sub
'makro spočítá součet řádků a vloží do listu
Sub memes()
Dim r As Long, s As Long
Dim soucet As Double
For r = 1 To Selection.Rows.Count
    soucet = 0
    For s = 1 To Selection.Columns.Count
        soucet = soucet + Selection.Cells(r, s).Value
    Next s
    Selection.Cells(r, s + 1) = soucet
Next r

End Sub
've výběru máme tabulku  název zboží, počet kusů, cena
'makro vloží do souboru všechny záznamy u kterých je počet kusů >10%
'při vložení program zachová strukturu záznamu
'atributy budou oddělené "; "
Sub memeses()
Dim r As Long, s As Long
Dim uloz As String

For r = 1 To Selection.Rows.Count
    For s = 1 To Selection.Columns.Count
        If (s = 2 And Selection.Cells(s) > 10) Then
            uloz = uloz & Selection.Cells(1) & ";" & Selection.Cells(2) & ";" & Selection.Cells(3) & ";"
        End If
    Next s
Next r

cesta = Application.GetSaveAsFilename + "csv"
Open cesta For Output As #1
Print #1, uloz
Close #1
End Sub
'někde chyba nemám na to nervy

Sub Jednicka()
Dim uloz As String
Dim i As Long

For i = 1 To Selection.Count
    If Not (Selection.Cells(i) = "") Then
        uloz = uloz & Selection.Cells(i) & ";"
    End If
Next i

cesta = Application.GetSaveAsFilename + "txt"
Open cesta For Output As #1
Print #1, uloz
Close #1

End Sub

Sub Dvojka()
Dim uloz As String
Dim r As Long, s As Long
Dim radek As String
uloz = ""
For r = 1 To Selection.Rows.Count
    For s = 1 To Selection.Columns.Count
            If Not (Selection.Cells(r, s) = "") Then
                radek = radek & Selection.Cells(r, s) & ";"
            End If
    Next s
    uloz = uloz & Left(radek, Len(radek) - 1)
    uloz = uloz & vbCrLf
     radek = ""
Next r

cesta = Application.GetSaveAsFilename + "txt"
Open cesta For Output As #1
Print #1, uloz
Close #1

End Sub

Sub Trojka()
Dim r As Long, s As Long
Dim prum As Double
Dim soucet As Double
soucet = 0
prum = Application.WorksheetFunction.Average(Selection)

For r = 1 To Selection.Columns.Count
    soucet = (Application.WorksheetFunction.Sum(Selection.Columns(r)))
    If (soucet > prum) Then
    For s = 1 To Selection.Rows.Count
           Selection.Cells(s, r).Font.ColorIndex = 3
    Next s
    End If
Next r



End Sub

Sub ctyrka()
Dim text As String
Dim adresa As String

adresa = InputBox("Název listu")
For i = 1 To Selection.Count
    Selection.Cells(i) = LTrim(Selection.Cells(i))
    Selection.Cells(i) = RTrim(Selection.Cells(i))

    For c = 1 To Len(Selection.Cells(i))
        If Not (Mid(Selection.Cells(i), c, 1) = " ") Then
        text = text & Mid(Selection.Cells(i), c, 1)
        Else
        text = text & "_"
        End If
    Next c
    Selection.Cells(i) = text
    text = ""
Next i
Selection.Copy Worksheets(adresa).Cells(1, 1)
Worksheets(adresa).Activate


End Sub


'Program pracuje s výběrem buněk.
'Všechny číselné hodnoty vložte do jednoho souboru a
'nečíselné hodnoty do druhého hodnoty vložte do souboru pod sebe

Sub osm()
Dim text As String
Dim uloz As String


For i = 1 To Selection.Count
   If (IsNumeric(Selection.Cells(i))) Then
        uloz = uloz & Selection.Cells(i) & ";"

   Else
        text = text & Selection.Cells(i) & vbCrLf
   End If

Next i

cesta = Application.GetSaveAsFilename + "txt"
Open cesta For Output As #1
Print #1, uloz
Close #1

cesta = Application.GetSaveAsFilename + "txt"
Open cesta For Output As #1
Print #1, text
Close #1
End Sub
'Uložit do formátu csv, tam, kde je text, tak csv
Sub Devítka()
Dim uloz As String
Dim r As Long, s As Long
Dim radek As String
uloz = ""
For r = 1 To Selection.Rows.Count
    For s = 1 To Selection.Columns.Count
        If (IsNumeric(Selection.Cells(r, s))) Then
                radek = radek & Selection.Cells(r, s) & ";"
        Else
                radek = radek & "?" & ";"
        End If
    Next s

    uloz = uloz & Left(radek, Len(radek) - 1)
    uloz = uloz & vbCrLf
     radek = ""
Next r

cesta = Application.GetSaveAsFilename + "csv"
Open cesta For Output As #1
Print #1, uloz
Close #1

End Sub
'oblast se zjistí pomocí posledních buněk v řádku a sloupci
Sub oblast()
radky = ActiveCell.CurrentRegion.Rows.Count
sloupce = ActiveCell.CurrentRegion.Columns.Count
pocetBunek = ActiveCell.CurrentRegion.Count
MsgBox ("řádků:" & radky & vbCrLf & "sloupců:" & sloupce)
End Sub

Sub vkladaniDat()
Dim r As Long
Do
    'Vrátí číslo řádku pod spojenou oblastí dat
    r = Worksheets("Data").Range("A1").CurrentRegion.Rows.Count + 1
    Worksheets("Data").Cells(r, 1).Value = InputBox("Název")
    Worksheets("Data").Cells(r, 1).Value = InputBox("Cena")
Loop Until MsgBox("Konec?", vbYesNo) = vbYes

End Sub
'Sečte buňky v oblasti dat, kde se nachází aktivní buňka.
'Součet vloží do buňky, která je pod výběrem
Rem v jeho posledním sloupci
Rem vloží komentář
Sub masmrtsd()
Dim soucet As Double


For r = 1 To ActiveCell.CurrentRegion.Rows.Count
    For s = 1 To ActiveCell.CurrentRegion.Columns.Count
        soucet = soucet + ActiveCell.CurrentRegion(r, s)
    Next s
Next r
MsgBox (soucet)
ActiveCell.CurrentRegion(ActiveCell.CurrentRegion.Rows.Count + 1, 1) = soucet
'.NoteText "to co bude v komentu"


End Sub


Sub fsafasf()

Dim soucet As Long
Dim i As Integer

For i = 1 To Selection.Count

soucet = soucet + Selection.Cells(i)

Next i

MsgBox (soucet)
End Sub

Sub fifi()

Dim i As Long


For i = 1 To Selection.Count
Selection.Cells (i)

Next i

End Sub