Index

Convert a column number / letter

Check sheet exist

Check file exist

Check path exist

Check an url

Format a Path

Go to a sheet in the active workbook

Add or remove Delimiter

Search the last row

Select a folder

Wait for given time

System Path

Protect a sheet

Show the colorindex

Convert a column number / letter  (scroll to top)

Convert a column number into a column letter or opposite

Function FuncColNumberToColLetter$(ByVal intColNumber%)
' Function: Change a column number into a column character (works up to ZZ)
' Input:    column number
' Output:   column letter as string
    Dim intFirst%, strCol$, intColNr%
        intColNr% = intColNumber%
        intFirst% = Int((intColNr% - 1) / 26)
        strCol$ = ""
        If intFirst% > 0 Then
            intColNr% = intColNr% - intFirst% * 26
            strCol$ = Chr(64 + intFirst%)
        End If
        FuncColNumberToColLetter$ = strCol$ & Chr(64 + intColNr%)
End Function

Function FuncColLetterToColNumber%(strColLetter$)
' Function: Change a column letter into a column number (works up to ZZ)
' Input:    column letter
' Output:   column number as integer
    Dim intFirst%, intSecond%, intCol%

    strColLetter$ = UCase(strColLetter$)
    Select Case Len(strColLetter$)
        Case 1:
            intCol% = Asc(strColLetter$) - 64
        Case 2:
            intFirst% = Asc(Left(strColLetter$, 1)) - 64
            intSecond% = Asc(Right(strColLetter$, 1)) - 64
            intCol% = intFirst% * 26 + intSecond%
        Case Else:
            MsgBox "can not identify the column number"
            intCol% = 0
    End Select
    FuncColLetterToColNumber% = intCol%
End Function

Check sheet exist  (scroll to top)

check is the sheet in the workbook

Function CheckIsSheet(strSheetName$, Optional strWorkbook$) As Boolean
' Function: Check Sheet exists
' Input:    strSheetName$= sheetname for the check
'           strWorkbook$ (Optional)= workbookname in case the sheet is not to search in the active workbook
' Output:   column letter as string
    Dim Wks As Worksheet
    CheckIsSheet = False
    If strWorkbook$ = "" Then strWorkbook$ = ActiveWorkbook.Name
    For Each Wks In Workbooks(strWorkbook$).Worksheets
        If strSheetName$ = Wks.Name Then
            CheckIsSheet = True
            Exit Function
        End If
    Next Wks
End Function

Check file exist  (scroll to top)

check is a file existing

Function CheckIsFile(ByVal strfile$, Optional bytPTyp As Byte) As Boolean
' Function: Check file exists local or in sharepoint - standard is local
' Input:    strfile$= filename including path for the check
'           bytPTyp (Optional): 1 = local address / 2=sharepoint address (need function CheckIsURL)
' Output:   Returns TRUE if the provided name points to an existing file - Returns FALSE if not existing, or it's a folder

    If bytPTyp = 2 Then
        If Left(strfile$, 4) = "http" Then
            CheckIsFile = CheckIsURL(strfile$)
        Else
            On Error Resume Next
            CheckIsFile = ((GetAttr(strfile$) And vbDirectory) <> vbDirectory)
        End If
    Else
        On Error Resume Next
        CheckIsFile = ((GetAttr(strfile$) And vbDirectory) <> vbDirectory)
    End If
End Function

Check path exist  (scroll to top)

check is the path existing

Public bytPathTyp as Byte ' can be set to 2 for sharepoint path

Function CheckIsPath(ByVal strpath$, Optional bytPTyp As Byte) As Boolean
' Function: Check path exists local or in sharepoint - standard is local
'           Standard folder get set too on simple way - for 100% you should use the registry value
' Input:    strpath$= pathname or standard folder aliases for the check
'           bytPTyp (Optional): 1 = local address / 2=sharepoint address (need function CheckIsURL)
' Output:   Returns TRUE if the provided name points to an existing file - Returns FALSE if not existing, or it's a folder

    If strpath$ = "Downloads" Then strpath$ = FuncGetSystemPath(1)
    If strpath$ = "Documents" Then strpath$ = FuncGetSystemPath(2)
    If strpath$ = "Desktop" Then strpath$ = FuncGetSystemPath(3)

     If bytPathTyp = 2 And bytPTyp = 0 Then
        bytPTyp = 2
    End If
    If bytPTyp = 2 Then
        If Left(strpath$, 4) = "http" Then
            CheckIsPath = CheckIsURL(strpath$)
        Else
            If Dir(strpath$, vbDirectory) = vbNullString Then
                CheckIsPath = False
            Else
                CheckIsPath = True
            End If
        End If
    Else
        If Dir(strpath$, vbDirectory) = vbNullString Then
            CheckIsPath = False
        Else
            CheckIsPath = True
        End If
    End If
End Function

Check an url  (scroll to top)

check is it an url and is it valid. Websites might need an authentication will not respond on this. Reference to Microsoft XML V6 required.

Function CheckIsURL(url$) As Boolean ' Reference to Microsoft XML V6 required
' Function: check an URL (Sharepoint Path or File) exists
' Ref.:     Require the VBA Reference 'Microsoft XML V6'
' Input:    url$= url to check
' Output:   Returns TRUE if it exist or FALSE if it not exist (or in case no access)
    Dim Request  As New MSXML2.XMLHTTP60
    On Error Resume Next
    With Request
        .Open "GET", url, False
        .send
        CheckIsURL = IIf(.Status = 200, True, False)
    End With
End Function

Format a Path  (scroll to top)

Format a Path of sharepoint or local address with then ending / or \ or replace standard path aliases

Public bytPathTyp as Byte ' can be set to 2 for sharepoint path

Function OpFormatPath(strpath$, Optional bytPTyp As Byte) As String
' Function: format a path correctly to use it with files and also replace standard path aliases (sort way - for 100% use a register solution)
' Input:    strpath$= path to analyse and correct
'           bytPTyp (Optional): 0 or empty = change to networkpath / 2 = use http path
' Output:   corrected path for use as string

    If strpath$ = "Downloads" Then strpath$ = FuncGetSystemPath(1)
    If strpath$ = "Documents" Then strpath$ = FuncGetSystemPath(2)
    If strpath$ = "Desktop" Then strpath$ = FuncGetSystemPath(3)

    If bytPathTyp = 2 And bytPTyp = 0 Then
        bytPTyp = 2
    End If
    If bytPTyp = 2 Then
        If Left(strpath$, 4) = "http" Then
            strpath$ = Replace(strpath$, "/:f:/", "/")
            strpath$ = Replace(strpath$, "/r/", "/")
            strpath$ = Replace(strpath$, "%20", " ")
            If InStr(1, strpath$, "?") > 0 Then strpath$ = Left(strpath$, InStr(1, strpath$, "?") - 1)
            If Right(strpath$, 1) <> "/" Then strpath$ = strpath$ & "/"
            'strPath$ = Replace(strPath$, " ", "%20")
            'strPath$ = Replace(strPath$, "%20", " ")
        Else
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        End If
    Else
        If Left(strpath$, 5) = "https" Then
            strpath$ = Replace(Replace(strpath$, "https:", ""), "/", "\")
            strpath$ = Replace(strpath$, Split(strpath$, "\")(2), Split(strpath$, "\")(2) & "@SSL")
            strpath$ = Replace(strpath$, "%20", " ")
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        ElseIf Left(strpath$, 5) = "http:" Then
            strpath$ = Replace(Replace(strpath$, "https:", ""), "/", "\")
            If Right(strpath$, 1) <> "/" Then strpath$ = strpath$ & "/"
        Else
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        End If
    End If
    OpFormatPath = strpath$
End Function

Go to a sheet in the active workbook  (scroll to top)

Go to a sheet in the active workbook. If the sheet is hidden it unhide it. If the parameter is empty and the caller is a button it takes the button name as sheetname

Sub OpGotoSheet(Optional strOpGotoSheet$)
' Function: Goto to the sheet from the parameter or based on the Text on the button
' Input:    strOpGotoSheet$ (Optional)= sheet name to go to
' Output:   N/A
    If strOpGotoSheet$ = "" Then ' Button as caller
        strOpGotoSheet$ = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
    End If
    strOpGotoSheet$ = Replace(strOpGotoSheet$, "Goto ", "")
    If CheckIsSheet(strOpGotoSheet$) = True Then
        If Worksheets(strOpGotoSheet$).Visible = 0 Then Worksheets(strOpGotoSheet$).Visible = -1
        Worksheets(strOpGotoSheet$).Select
    Else
        MsgBox strOpGotoSheet$ & " do not found!"
    End If
End Sub

Add or remove Delimiter  (scroll to top)

Add or remove Delimiter at the beginn or end.

Function OpAddRemoveDelimiter$(strVal$, Optional strDelimiter$, Optional bytTyp As Byte)
' Function: Check and Add/Remove Delimiter on the beginn and/or end
' Input:    strVal$ = the Value where the Delimiter has to be added or removed
'           Delimiter$ (Optional)= the character for add/remove - default is ";"
'           bytTyp (Optional):  1= add the Delimiter right - not check left
'                              10= add the Delimiter left - not check right
'                              12= add the Delimiter left, remove right (is the default)
'                              21= add the Delimiter right, remove left
'                              11= add the Delimiter on both end
'                              22= remove the Delimiter on both end
' Output:   the value as string with the added delimiter
    If strDelimiter$ = "" Then strDelimiter = ";"
    If strVal$ <> "" Then
        Select Case bytTyp
            Case 1:
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 10:
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
            Case 11:
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 12: ' default if nothing defined
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) = strDelimiter$ Then strVal$ = Left(strVal$, Len(strVal$) - 1)
            Case 21
                If Left(strVal$, 1) = strDelimiter$ Then strVal$ = Right(strVal$, Len(strVal$) - 1)
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 22
                If Left(strVal$, 1) = strDelimiter$ Then strVal$ = Right(strVal$, Len(strVal$) - 1)
                If Right(strVal$, 1) = strDelimiter$ Then strVal$ = Left(strVal$, Len(strVal$) - 1)
            Case Else
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
        End Select
    End If
    OpAddRemoveDelimiter$ = strVal$

End Function

Search the last row  (scroll to top)

Search the last row by checking a key column or just the first 7 columns if they have entry. Excel sometimes do not recognise the last row if some format is further below.

Function FuncLastRow(strfile$, strTab$, Optional ByVal intStartRow%, Optional strKeyCol$) As Single
' Function: Check Data end Row, Try to find last row on a defined KeyCol or just by check first 7 columns. 5 empty rows = defined end of data
' Input:    strfile$ = Filename where it has to be checked (has to be open)
'           strTab$ = Sheet name to check
'           intStartRow% (Optional)= Optional the start where the check should start - default first row
'           strKeyCol$ (Optional) = Optionale Column which has to be checked - default first 7 columns
' Output:   number of the last row with data as single

Dim sngUsedRows!, nRow!, strVal$, bytC As Byte, bytCTotal As Byte

    bytCTotal = 5 ' to check empty rows to make sure there is not just a single or like 2 empty rows
    If intStartRow% = 0 Then intStartRow% = 1
    sngUsedRows! = Workbooks(strfile$).Worksheets(strTab$).UsedRange.SpecialCells(xlCellTypeLastCell).Row

    For nRow! = intStartRow% To sngUsedRows! + 3
        bytC = 0
        If strKeyCol$ <> "" Then ' if no key defined just read all data
            For bytC = 0 To bytCTotal
                strVal$ = Workbooks(strfile$).Worksheets(strTab$).Range(strKeyCol$ & nRow! + bytC).Value
                strVal$ = Trim(strVal$)
                If strVal$ <> "" Then Exit For
            Next
            If bytC >= bytCTotal Then
                FuncLastRow! = nRow!
                Exit For
            End If
        Else ' check 7 first columns (slow version)
            For bytC = 0 To bytCTotal
                strVal$ = Workbooks(strfile$).Worksheets(strTab$).Cells(nRow!, 1).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 2).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 3).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 4).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 5).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 6).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 7).Value
                strVal$ = Trim(strVal$)
                If strVal$ <> "" Then Exit For
            Next
            If bytC >= bytCTotal Then
                FuncLastRow! = nRow!
                Exit For
            End If
        End If
    Next
End Function

Select a folder  (scroll to top)

Open a dialogbox for select a folder and give the foldername back.

Function FuncGetFolder(Optional strTitle$) As String
' Function: Open a dialog for select a folder and give selected folder back
' Input:    strTitle$ (Optional)= Title for the dialogbox
' Output:   Folder as string

    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        If strTitle$ <> "" Then
            fldr.Title = strTitle$
        Else
            .Title = "Select a Folder"
        End If
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FuncGetFolder = sItem
    Set fldr = Nothing
End Function

Wait for given time  (scroll to top)

Wait the processing of vba for given seconds

Function OpWait(bytSeconds As Byte)
' Function: wait as many seconds as the input is (max 255)
' Input:    bytSeconds = seconds to wait as byte
' Output:   N/A 
    Dim bytMinutes As Byte
    If bytSeconds > 60 Then
        bytMinutes = Int(bytSeconds / 60)
        bytSeconds = bytSeconds - (bytMinutes * 60)
    Else
        bytMinutes = 0
    End If
    Application.Wait (Now + TimeValue("0:" & Right("0" & bytMinutes, 2) & ":" & Right("0" & bytSeconds, 2)))
End Function

System Path  (scroll to top)

Give some system path back

Function FuncGetSystemPath(bytTyp As Byte) As String
' Function: returns user specific folders (simple way - not works in all cases)
' Input:    bytTyp=number for the liked system path
' Output:   path as string 
    Select Case bytTyp
        Case 1: FuncGetSystemPath = Environ("USERPROFILE") & "\Downloads"
        Case 2: FuncGetSystemPath = Environ("USERPROFILE") & "My Documents"
        Case 3: FuncGetSystemPath = Environ("USERPROFILE") & "\Desktop"
    End Select
End Function

Protect a sheet  (scroll to top)

Protect or unprotect a sheet in the active workbook. Can be forced or just do opposite as it is.

Function OpProtectSheet(Optional bytStat As Byte, Optional strSheet$)
' Function: returns user specific folders (simple way - not works in all cases)
' Input:    strSheet$ = the to protect sheet - if empty protect/unprotect active sheet
'           bytStat 1= protect sheet, 2=unrotect sheet , empty is opposite now
' Output:   N/A

    If strSheet$ = "" Then strSheet$ = ActiveSheet.Name
    If IsEmpty(bytStat) Then
        If Worksheets(strSheet$).ProtectContents = True Then
            bytStat = 2
        Else
            bytStat = 1
        End If
    End If

    If bytStat = 1 Then
        On Error Resume Next
        Worksheets(strSheet$).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Err.Clear
    Else
        On Error Resume Next
        Worksheets(strSheet$).Unprotect
        Err.Clear
    End If

End Function

Show the colorindex  (scroll to top)

Show the colorindex of the text in the active cell and write the number into it - if no text then it takes the background color

Sub OpGetColor()
' write the colorindex of the active cell backgroundcolor/Textcolor into the cell
    If ActiveCell.Interior.ColorIndex = xlColorIndexNone Then ' active cell has a blank background

        If MsgBox("Do you like to write the actual colorindex (" & ActiveCell.Font.ColorIndex & ") in the cell " & Replace(ActiveCell.Address, "$", "") & "?", vbYesNo) = vbYes Then
            ActiveCell.Value = ActiveCell.Font.ColorIndex
        End If
    Else
        If MsgBox("Do you like to write the actual colorindex (" & ActiveCell.Interior.ColorIndex & ") in the cell " & Replace(ActiveCell.Address, "$", "") & "?", vbYesNo) = vbYes Then
            ActiveCell.Value = ActiveCell.Interior.ColorIndex
        End If
    End If

End Sub