Online Trick: VBA

Showing posts with label VBA. Show all posts

Sunday, September 20, 2015

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

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).

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

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

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+q" just after a typo occurred.

Download-Instructions:
To use this macro you need to download this word template and save it to your default Microsoft Office Startup folder (or wherever you store your customized templates, the path can be found in word in tools / options / save tab). If stored at the right place the keyboard shortcut macro should work whenever you open a Word file on this computer.

Code:

Sub FirstSugg()

'Author: Kay Cichini
'Date: 2012-01-17
'Info: The template was created with ms word 2003

Dim r As Range
Selection.MoveLeft Unit:=wdWord
Set r = Selection.GoToNext(wdGoToSpellingError)

With r.GetSpellingSuggestions()
  If .Count > 0 Then
    r.Text = .Item(1).Name
  Else: MsgBox ("Lacking Suggestion!")
  End If
End With

Selection.MoveRight Unit:=wdWord
End Sub

Sub Export_CSV()

    '***************************************************************************************
    'author:    kay cichini
    'date:      26102014
    '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
    ActiveWorkbook.ActiveSheet.UsedRange.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 True
    End With
    Application.DisplayAlerts = True
End Sub

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:

1. Insert a command-button from the control toolbox (view / toolbars / control toolbox)
2. Double cllick the command button & within the Visual Basic editor insert the below code.

'Info: Macro that searches Google for a definition
'for the word in the active cell.

'Usage: With mouse select cell with word to be
'defined/searched, then hit the button.

Private Sub CommandButton1_Click()

    Dim mystr As String

    mystring = ActiveCell.Value

    mylink = "http://www.google.at/search?q=define%3A+" & mystring

    ThisWorkbook.FollowHyperlink (mylink)

End Sub

3. In design mode add captation, re-size, place, format your button, etc.
4. Exit design mode.
5. Your finished..

ps: you could also do this using the xls-function Hyperlink() but as you may have noticed, saving xls-files containing this function causes some trouble (warning messages, large storage..)

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...

(download template)

Note: If you download the template you will need to use your own database and change the path in the script... Else you may contact me for the text-file with species names...

For your own word list: use a tab-delimited txt-file with unique strings without capitalization, like:

yourtextfile.txt:
-------------------------------
one
two
three
...
-------------------------------

Code:

'macro name: ReformatListMatches
'purpose: compares words from document with words from file
'author: kay cichini
'date: 2012-01-04
'licence: cc by-nc-sa

'specifications:
'before running the macro, add a commandbar called "mycombar" and assign the macro "ReformatListMatches" to it,
'run line 8 one time, then disable it, then save file to a template (.dot) and store it at your templates' folder.
'if you don't want a command bar, just skip the above part and don't run line 8!

Sub ReformatListMatches()

'CommandBars("mycombar").Controls(1).TooltipText = "calls procedure that re-formats words that match word list"
'this sets tooltip info, run this only once (!!), otherwise you will be asked to save changes to the dot file
'everytime you close a word doc.

time_start = Timer()

If MsgBox("Re-format matches?" & vbLf & " " & vbLf & "..may take some time" & vbLf & "..be patient! (the active window will be temporarily invisible to speed up process)", vbOKCancel + vbQuestion, "SpKursiv") = vbOK Then
 
Dim vntArrWords As Variant
Dim lngI As Long
Dim strText As String
Dim strPathFile As String
Dim lngFN As Long
 
strPathFile = "C:\LogoXP\SP_words_tab.txt"
'the database with names to compare
 
lngFN = FreeFile
Open strPathFile For Binary As lngFN
 strText = Space(LOF(lngFN))
 Get lngFN, 1, strText
Close lngFN
 
System.Cursor = wdCursorWait
 
vntArrWords = Split(strText, vbCrLf, -1, 1)

ActiveWindow.Visible = False

With ActiveDocument.Content.Find
  .ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchCase = False
  .MatchWholeWord = True
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Replacement.ClearFormatting
  .Replacement.Text = "^&"               'replaces match with the original string (but with new format!)
  .Replacement.Font.Italic = True        'here i determine the new format
  For lngI = 0 To UBound(vntArrWords)
    .Text = Trim(vntArrWords(lngI))
    .Execute Replace:=wdReplaceAll
  Next
End With

ActiveWindow.Visible = True

time_end = Timer()

MsgBox "finished!" & vbLf & "(calculation time (mm:ss) = " & time_end - time_start & ")"

Else: Exit Sub
End If

End Sub

BTW: just found a similar tutorial at http://www.garyradley.com/vbatutor/tut4.htm

Online Trick