Fragmenty kódu

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Procedury pro zrychleni behu makra a obnoveni vlastnosti aplikace
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub SpeedUp(Optional ByVal sStatusText As String = "Working!")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
        .StatusBar = sStatusText
    End With
End Sub
Public Sub SpeedDown(ByVal bShowMSG As Boolean, Optional ByVal dProcessTime As Double = 0)
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .StatusBar = False
        .CutCopyMode = False
        If bShowMSG Then MsgBox "Solution time -->" & Format(dProcessTime, "hh:mm:ss"), vbInformation + vbOKOnly, "Solution result"
    End With
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Procedura pro skryti / odkryti listu
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub ShowHideSheet(sSheetName As String, bHide As Boolean)
    Dim ws As Worksheet, bLock As Boolean
    Set ws = ThisWorkbook.Sheets(sSheetName)
    If ThisWorkbook.ProtectStructure Then
        bLock = True
        ThisWorkbook.Unprotect Password:=sPassword
    End If
    If bHide Then
        ws.Visible = xlSheetVisible
        ws.Activate
    Else
        ws.Visible = xlSheetVeryHidden
    End If
    If bLock Then ThisWorkbook.Protect sPassword, True
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Funkce pro získání názvu souboru z cesty na soubor
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function GetFileNameFromUrl(sUrlPath As String, Optional bSuffix As Boolean = False) As String
	Dim iDotPos As Integer, sPath As String: sPath = sUrlPath
	sPath = Mid(Mid(sPath, InStrRev(sPath, "/") + 1), InStrRev(sPath, "\") + 1)
	If bSuffix Then iDotPos = InStr(1, sPath, ".") - 1: sPath = Left(sPath, iDotPos)
	GetFileNameFromUrl = sPath
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Funkce pro prevedeni cisla sloupce na pismeno sloupce
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function NumToAlphabet(iColNum As Integer) As String
    Dim sAlphabet As String, iCount As Integer, iCache As Integer
    Dim sFirst As String, sSecond As String
    sAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    iCount = 26
    If iColNum > iCount Then
        iCache = Int(iColNum / iCount)
        If iColNum Mod iCount = 0 Then
            iCache = iCache - 1
            sFirst = Mid(sAlphabet, iCache, 1)
            sSecond = "Z"
        Else
            sFirst = Mid(sAlphabet, iCache, 1)
            sSecond = Mid(sAlphabet, iColNum - (iCache * iCount), 1)
        End If
        NumToAlphabet = sFirst & sSecond
    Else
        NumToAlphabet = Mid(sAlphabet, iColNum, 1)
    End If
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Funkce FileDialogOpen pro ziskani odkazu na soubor zpracovani
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function UseFileDialogOpen() As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Show
        .Title = "Vyberte soubor pro zpracování"
        If .SelectedItems.Count = 0 Or .SelectedItems.Count > 1 Then
            MsgBox "Je potřeba vybrat soubor pro zpracování!", vbCritical + vbOKOnly, "Informace"
            Exit Function
        Else
            UseFileDialogOpen = .SelectedItems(1)
        End If
    End With
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Procedura pro smazani radku tabulky
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub DeleteTableRows(sSheetName As String, sTableName As String)
    Dim oTable As ListObject, oListRows As ListRows
    Set oTable = ThisWorkbook.Sheets(sSheetName).ListObjects(sTableName)
    Set oListRows = oTable.ListRows
    If oListRows.Count > 0 Then
        oTable.Range.Rows("2:" & oListRows.Count + 1).Delete
    End If
End Sub