Excel VBA User Defined Function for Transformation of Braun-Blanquet Values to Precentages of Vegetation Cover

Function Transf_BraunBlanquet(ByVal BB_Str As String) As String

'Transformation of Braun-Blanquet 'Artmächtigkeit' to percentage cover (similar to usage in TurboVeg or twinspan)
'The key value mapping can be altered depending on specific requirements
'This UDF is used in the UDF SumKum_BraunBlanquet(), which will apply the Transformation on a range of values and
'will sum the transformed percentages. This cumulative sum can be used to check if the Braun-Blanquet estimation for
'a vegetation layer is reasonable.

    With CreateObject("Scripting.Dictionary")
        '~~> first transfer your list in Dictionary
        .Add "r", "0"
        .Add "+", "0"
        .Add "1", "1"
        .Add "2m", "2"
        .Add "2a", "10"
        .Add "2b", "20"
        .Add "3", "37,5"
        .Add "4", "67,5"
        .Add "5", "87,5"
        
        If Len(BB_Str) = 0 Then
        '~~> case: empty cell
            Transf_BraunBlanquet = 0
            Exit Function
        End If
        
        For Each elem In .keys
            key = elem
            If key = BB_Str Then
                Transf_BraunBlanquet = .Item(elem) * 1
                Exit Function
            End If
        Next elem
        
    End With
    
End Function


Function SumKum_BraunBlanquet(Rng As Range) As Double
'See comments on Transf_BraunBlanquet() for explanations

    Dim Sum As Double
    Dim RngArr As Variant
    
    RngArr = Application.Transpose(Rng) 'dumps range values to array
    
    For Each elem In RngArr
        Sum = Sum + Transf_BraunBlanquet(elem)
    Next elem
    
    SumKum_BraunBlanquet = Sum
    
End Function

VBA Macro to Export Data from Excel Spreadsheet to CSV

Resources: http://stackoverflow.com/questions/13496686/how-to-save-semi-colon-delimited-csv-file-using-vba
and: http://stackoverflow.com/questions/35655426/excel-vba-finding-recording-user-selection

Sub Export_CSV()

    '***************************************************************************************
    'author:    kay cichini
    'date:      26102014
    'update:    16122016
    'purpose:   export current spreadsheet to csv.file to the same file path as source file
    '
    ' !!NOTE!!  files with same name and path will be overwritten
    '***************************************************************************************
  
    Dim MyPath As String
    Dim MyFileName As String
    Dim WB1 As Workbook, WB2 As Workbook
    
    Set WB1 = ActiveWorkbook

    '(1) either used range in active sheet..
    'ActiveWorkbook.ActiveSheet.UsedRange.Copy
    
    '(2) or alternatively, user selected input range:
    Dim rng As Range
    Set rng = Application.InputBox("select cell range with changes", "Cells to be copied", Default:="Select Cell Range", Type:=8)
    Application.ScreenUpdating = False
    rng.Copy

    Set WB2 = Application.Workbooks.Add(1)
    WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
    
    MyFileName = "CSV_Export_" & Format(Date, "ddmmyyyy")
    FullPath = WB1.Path & "\" & MyFileName
    
    Application.DisplayAlerts = False
    If MsgBox("Data copied to " & WB1.Path & "\" & MyFileName & vbCrLf & _
    "Warning: Files in directory with same name will be overwritten!!", vbQuestion + vbYesNo) <> vbYes Then
        Exit Sub
    End If
    
    If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
    With WB2
        .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=False
        .Close False
    End With
    Application.DisplayAlerts = True
End Sub

VBA Subroutine to Clear All Filters in Excel-Table

Sub filter_clear()

'****************************************************************************************************************
'author:    kay cichini
'date:      06072016
'purpose:   clear all filters in a preformated excel tabel
'****************************************************************************************************************

Dim SelectedCell As Range
Dim TableName As String
Dim ActiveTable As ListObject

Set SelectedCell = ActiveCell

'Determine if ActiveCell is inside a Table
  On Error GoTo NoTableSelected
    TableName = SelectedCell.ListObject.Name
    Set ActiveTable = ActiveSheet.ListObjects(TableName)

    If ActiveTable.ShowAutoFilter Then
      'MsgBox "AutoFilters are turned on"
      If ActiveTable.AutoFilter.FilterMode Then
        'MsgBox "Filter is actually set"
        ActiveTable.AutoFilter.ShowAllData
      End If
    End If
  On Error GoTo 0

Exit Sub

'Error Handling
NoTableSelected:
  MsgBox "There is no Table currently selected! (You need to activate a cell in the Table to be cleared!)", vbCritical

End Sub

VBA Spreadsheet Function for Substring Inbetween Strings

Function Substring2(theString As String, str1 As String, repstr1 As Integer, Optional str2 As Variant, Optional repStr2 As Variant) As String

    '****************************************************************************************************************
    'author:    kay cichini
    'date:      04112014
    'purpose:   find substring deligned by the x-th repition of one string at the left side
    '           and anothers string x-th repition at the right side
    'str1:      first string to be matched
    'str2:      second string to be matched, optional
    'repstr1:   nth repition of str1 to be matched
    'repstr2:   nth repition of str2 to be matched, optional
    '           with optional arguments ommited function will return substring ending with the last character of the
    '           searchstring
    '----------------------------------------------------------------------------------------------------------------
    'example:   Substring2("1234 678 101214 xxxx"; " "; 2; "x"; 3)
    '           will match position 10 after the second repition of str1, find position 20 after the third "x"
    '           then apply a mid-function with signature 'mid(string, start, length)',
    '           where the position 10 is the start and length is position 20 - len("x") - 10 = 9
    '           and the result is "101214 xx"
    '****************************************************************************************************************
    
    Dim start1, start2, lenStr1, lenStr2, length As Integer
    
    If IsMissing(str2) And IsMissing(repStr2) Then
    
        'case when last char in string should be matched
        '-----------------------------------------------
        
        start1 = 1
        lenStr1 = Len(str1)
        
        If InStr(start1, theString, str1) = 0 Then
            '0 -> String couldn't be matched!
            Exit Function
        End If
        
        For i = 0 To repstr1 - 1
            start1 = InStr(start1, theString, str1) + lenStr1
        Next i
        
        length = Len(theString) - start1 + 1
        Substring2 = Mid(theString, start1, length)

    Else
    
        'other cases
        '-----------
        start1 = 1
        lenStr1 = Len(str1)
        start2 = 1
        lenStr2 = Len(str2)
        
        If InStr(start1, theString, str1) = 0 Or InStr(start2, theString, str2) = 0 Then
            '0 -> String couldn't be matched!
            Exit Function
        End If
        
        For i = 0 To repstr1 - 1
            start1 = InStr(start1, theString, str1) + lenStr1
        Next i
        
        For i = 0 To repStr2 - 1
            start2 = InStr(start2, theString, str2) + lenStr2
        Next i

        length = start2 - lenStr2 - start1
        Substring2 = Mid(theString, start1, length)
        
    End If
    
End Function

Add Comments in MS-Word using VBA

This VBA procedure (1) Searches words ("Str1", "Str2",..) and adds commentboxes to it and (2) changes the initials used in the box:

Sub CommentBox()

    Dim range As range
    Dim i As Long
    Dim TargetList
    Dim cm As Comment
    
    TargetList = Array("Str1", "Str2")
    
    For i = 0 To UBound(TargetList)
    
    Set range = ActiveDocument.range
    
    With range.Find
    .Text = TargetList(i)
    .Format = True
    .MatchCase = False
    .MatchWholeWord = True
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
        
    Do While .Execute(Forward:=True) = True

        Set cm = range.Comments.Add(range:=range, Text:="Hallo")
        cm.Author = "InternalName"
        cm.Initial = "Initials"
        
        Loop
    
    End With

    Next

With ActiveDocument.Styles("Kommentartext").Font
        .Size = 12
        .Bold = True
        .Italic = True
        .Color = wdColorBlue
End With

End Sub

WIKI Search in Excel with VBA

Here's a VBA code snippet for searching a string in a cell in WIKIPEDIA:

Sub wiki()

Dim searchstr As String
Dim searchsadd As String

searchstr = ActiveCell.Value
searchadd = "http://en.wikipedia.org/w/index.php?title=Special%3ASearch&profile=default&search=" & searchstr & "&fulltext=Search"
  
  If Len(searchstr) = 0 Then
    MsgBox "The active cell is empty.. Nothing to search for..", vbOKOnly, "WIKIPEDIA"

  Else:
    ActiveWorkbook.FollowHyperlink searchadd, NewWindow:=True
    Application.StatusBar = "WIKI search for: " & searchstr
  End If
  
End Sub

Match Words in MS-Word File with Words in another File and Apply New Format Using VBA

I present a macro that I wrote for re-formatting scientific species names (it is common to use italic fonts for that) in a Word file. Therefore I used a database of central European species names - this is compared with the words in my file and matches are re-formatted...

Search Google Definition for Words in an Excel-File Using VBA

I have a glossary of words held in an excel-workbook. For getting instant definitions from Google I wrote a small macro which does this for me with one click.

This is how it is done:

Fast Correction of Typos in MS Word with VBA

..I use a macro to quickly fix misspelled words. More precisely, the misspelled word is replaced by the first suggestion from the spelling checker. The macro is called by hitting "strg+shift+q" just after a typo occurred.

Species Recording Form

When recording species abundance data you often have endless rows with species names and one gets swollen eyes from searching the right line for each data-entry. Therefore I made myself a handy xls-file to collect species abundance data.

In it a VBA-macro is called with a keybord short-cut which matches a species short name you type in the active cell and jumps to the line with that species, the search entry is deleted automatically and you are in the cell where you want to add data... (download).