Office Apps Tips & Techniques

Friday, 11 June 2021

Useful VBA utilities for Microsoft Word (Core Eddie-Code)

Useful VBA utilities for Microsoft Word (Core Eddie-Code):

Author: Eddie Kumar Shrivastava

'******************************************************************************************

'Written by: Eddie Kumar Shrivastava

'Description: Eddie-Tools to speed up the data-processing/editing/formatting etc. for Microsoft Word.

'Readonly link: https://officeapptips.blogspot.com/2021/06/useful-vba-utilities-for-microsoft-word.html

'Editable-Repo: https://www.blogger.com/u/1/blog/posts/5593580733288490407

'Date Created: 05-02-2012

'Last Modified: 23-06-2022

'Version: 4.11

'Version info/Change Log/Subs-List:

'------------------------------------------------------------------------------------------

' SUBs - Keyboard-Shortcuts Assigned

'------------------------------------------------------------------------------------------

'''''''''''''''''''''''' SPELLING & GRAMMAR ''''''''''''''''''''''''

'- Sub IgnoreSpellingAndGrammar() - Alt + i

'- Sub DontIgnoreSpellingAndGrammar() - Ctrl + Shift + Alt + i

'- Sub IgnoreSpellingInBlockBrackets() - Ctrl + Shift + Alt + [

'''''''''''''''''''''''' SPACING ''''''''''''''''''''''''

'- Sub RemoveSpaceAboveBelow() - Alt + R

'- Sub AddSpaceAboveBelow() - Shift + Alt + R

'- Sub AddSpaceAbove() - Ctrl + Shift + Alt + R

'- Sub AddMinorSpaceAbove() -

'- Sub AddSpaceAboveDONOTUSE() -

'- Sub LineSpacing1_3() - Alt + 3

'''''''''''''''''''''''' TABLES ''''''''''''''''''''''''

'- Sub FormatTable() - Ctrl + Shift + Alt + F

'- Sub TabsToTable() - Alt + T / Ctrl + Shift + Alt + T

'''''''''''''''''''''''' HIGHLIGHTING ''''''''''''''''''''''''

'- Sub Highlight1stCharacter() - Ctrl + Shift + Alt + H

'- Sub Caps1stChar() -

'- Sub BoldTopicsInList() - Ctrl + Shift + Alt + B

'- Sub HighlightCodeTillColon() - Ctrl + Shift + Alt + C

'''''''''''''''''''''''' HEADERS ''''''''''''''''''''''''

'- Sub SetHeading4() - Ctrl + Alt + 4 (in line with other Headers' shortcuts)

'- Sub SetHeading5() - Ctrl + Alt + 5 (in line with other Headers' shortcuts)

'''''''''''''''''''''''' Ed-Utilities ''''''''''''''''''''''''

'- Sub WriteSequenceFile() -

'- Sub PasteAsUnformattedText() - Alt + V

'- Sub eq_JiraLinkFromSelection() - Ctrl + Shift + Alt + L

'- Sub eq_7IMBugFromSelection() - Ctrl + Shift + Alt + K

''''''''''''''''''''''''Ed-VBA-Reusable-Code-Assist''''''''''''''''''''''''

'- Sub FlushImmediateWindow() - Ctrl + Shift + Alt + Del

'- Sub ConfirmRun() -

'''''''''''''''''''''''' Export-Utilities ''''''''''''''''''''''''

'- Sub ExportAsPDF() - Ctrl + Shift + Alt + P

'- Sub SaveAsDocx() - Ctrl + Shift + Alt + S

'''''''''''''''''''''''' Ed-Useful-VBA-Code-Sample ''''''''''''''''''''''''

'- Sub ReplaceSomeTextUsingRegExp() -

'- Sub EmptyParagraphsCount() -

'- Sub ParseSentenceInEachParagraph() -

'- Sub RangeSelectionTest() -

'- Sub CatchSpecificError() -

'- Function Clipboard() -

'- Sub ClipboardTest() -

'- Sub getPathCurrentFile() -

'- Sub GetPathsOfCurrentFileWordBinaryAndMyDoc()

'- Sub getUserDesktopPath() -

'******************************************************************************************

'''''''''''''''''''''''' Spalling & Grammar ''''''''''''''''''''''''

'Following disables the "Spelling & Grammar" checks (i.e. ignores spellings/grammar errors) for the selected text:

'Select (a paragraph) then run:

Sub IgnoreSpellingAndGrammar()

Selection.NoProofing = True

End Sub

'Following enables the "Spelling & Grammar" checks for the selected text:

'Select (a paragraph) then run:

Sub DontIgnoreSpellingAndGrammar()

Selection.NoProofing = False

End Sub

'Following disables the "Spelling & Grammar" checks for the text within Square Brackets and formats (main) word preceding to '[' as bold.

'Select a line/paragraph containing text within [block brackets] then run:

Sub IgnoreSpellingInBlockBrackets()

Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticCharacters) 'excludes punctuations.

If cnt <= 0 Then

MsgBox "Nothing selected, please select line(s) to disable the 'Spelling & Grammar' checks for the text within Square Brackets."

End

End If

' For Each l In Selection.Words

' Debug.Print w 'NOT useful as it treats [square brackets] as separate word.

' Next

Dim paras As Paragraphs

Dim para As Paragraph

Dim sents As Sentences

Dim paraText As String

Dim sent As Range

Dim selRng As Range: Set selRng = Selection.Range

Set paras = selRng.Paragraphs 'for selection only

'Set paras = ActiveDocument.Paragraphs 'for whole document

Dim t As String

Dim intStart, intEnd As Integer

Selection.MoveLeft Unit:=wdCharacter, Count:=1

For Each para In paras

paraText = Trim(para.Range.Text)

paraTextLength = Len(paraText)

If (paraTextLength > 1) Then '1 new-line char is always present in each paragraph.

'Debug.Print (paraText)

t = paraText

intStart = InStr(1, t, "[", vbTextCompare)

If (intStart < 1) Then

GoTo NextIteration

End If

'Bold preceding word:

intEnd = intStart - 1

intStart = 1

Debug.Print intEnd

Debug.Print intStart

Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend

Selection.Font.Bold = True

'NoProofing:

intEnd = InStr(intStart, t, "]", vbTextCompare)

intEnd = intEnd + 1

Selection.MoveRight Unit:=wdCharacter, Count:=intStart - 1

Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend

Selection.NoProofing = True

End If

NextIteration:

Selection.MoveDown Unit:=wdParagraph, Count:=1 ', Extend:=wdExtend 'default value is wdLine

selRng.Select

End

'FOLLOWING WORKS FINE BUT NOT USEFUL IN THIS CONTEXT AS LONG & TEDIOUS:

'Count = Selection.Characters.Count

'For i = 1 To Count

' If Selection.Characters(i).Text = "[" Then

' 'Set rStart = Selection.Characters(i).index

' ElseIf Selection.Characters(i).Text = "]" Then

' 'Set rEnd = Selection.Characters(i).Range

' End If

'Next

'Dim rng As Range

'Set rng = ActiveDocument.Range(start:=rStart, End:=rEnd)

'rng.Select

'Selection.Font.Bold = True

'With Selection.Find

'.Forward = True

'.ClearFormatting

'.MatchWholeWord = True

'.MatchCase = False

'.Wrap = wdFindContinue

'.Execute FindText:="["

'End With

'Dim rng As Range

'Set rng = ActiveDocument.Range(start:=ActiveDocument.Paragraphs(1).Range.start, End:=ActiveDocument.Paragraphs(4).Range.End)

'rng.Select

'Selection.Font.Bold = True

End Sub

'Following disables the "Spelling & Grammar" checks for the text within Square Brackets (without bold formatting):

'Select a line/paragraph containing text within [block brackets] then run:

Sub IgnoreSpellingInBlockBracketsWihtoutBoldPreceding()

Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticCharacters) 'excludes punctuations.

If cnt <= 0 Then

MsgBox "Nothing selected, please select line(s) to disable the 'Spelling & Grammar' checks for the text within Square Brackets."

End

End If

' For Each l In Selection.Words

' Debug.Print w 'NOT useful as it treats [square brackets] as separate word.

' Next

Dim paras As Paragraphs

Dim para As Paragraph

Dim sents As Sentences

Dim paraText As String

Dim sent As Range

Dim selRng As Range: Set selRng = Selection.Range

Set paras = selRng.Paragraphs 'for selection only

'Set paras = ActiveDocument.Paragraphs 'for whole document

Dim t As String

Dim intStart, intEnd As Integer

Selection.MoveLeft Unit:=wdCharacter, Count:=1

For Each para In paras

paraText = Trim(para.Range.Text)

paraTextLength = Len(paraText)

If (paraTextLength > 1) Then '1 new-line char is always present in each paragraph.

'Debug.Print (paraText)

t = paraText

intStart = InStr(1, t, "[", vbTextCompare)

If (intStart < 1) Then

GoTo NextIteration

End If

intEnd = InStr(intStart, t, "]", vbTextCompare)

intEnd = intEnd + 1

'Selection.MoveLeft Unit:=wdCharacter, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=intStart - 1

Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend

'Selection.Font.Bold = True

Selection.NoProofing = True

End If

NextIteration:

Selection.MoveDown Unit:=wdParagraph, Count:=1 ', Extend:=wdExtend 'default value is wdLine

selRng.Select

End Sub

'''''''''''''''''''''''' Spacing ''''''''''''''''''''''''

'Following sub removes Paragraph-Spacing from above & below the selected text:

Sub RemoveSpaceAboveBelow()

Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle

With Selection.ParagraphFormat

.SpaceBefore = 0

.SpaceBeforeAuto = False

.SpaceAfter = 0

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceSingle

End With

End Sub

'Following adds Paragraph-Spacing above & below the selected line:

Sub AddSpaceAboveBelow()

With Selection.ParagraphFormat

.SpaceBefore = 6

.SpaceBeforeAuto = False

.SpaceAfter = 6

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceSingle

' .MirrorIndents = False

' .TextboxTightWrap = wdTightNone

' .CollapsedByDefault = False

End With

End Sub

'Following sub adds Paragraph-Spacing above the selected text:

Sub AddSpaceAbove()

Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle

With Dialogs(wdDialogFormatParagraph)

.Before = 14

.After = 0

.NoSpaceBetweenParagraphsOfSameStyle = False

.Execute

End With

End Sub

'Following sub adds smaller Paragraph-Spacing above the selected text:

Sub AddMinorSpaceAbove()

With Selection.ParagraphFormat

.SpaceBefore = 4

.SpaceBeforeAuto = False

.SpaceAfter = 0

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceSingle

End With

End Sub

'Following uses standard VBA code in attempt to add Paragraph-Spacing above the selected text, however doesn't work see PROBLEM:

Sub AddSpaceAboveDONOTUSE()

With Selection.ParagraphFormat

.SpaceBefore = 8

.SpaceBeforeAuto = False

.SpaceAfter = 2

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceSingle

' .MirrorIndents = False

' .TextboxTightWrap = wdTightNone

' .CollapsedByDefault = False

End With

'PROBLEM WITH NoSpaceBetweenParagraphsOfSameStyle RESETS ENTIRE STYLE:

'ActiveDocument.Styles("Normal").NoSpaceBetweenParagraphsOfSameStyle = False

'Selection.Style.NoSpaceBetweenParagraphsOfSameStyle = False

'SOLUTION: use Word Dialogs control (wdDialogFormatParagraph)

End Sub

'Following sub sets the line spacing to 1.3 on selected text and removes Paragraph-Spacing from above & below:

Sub LineSpacing1_3()

With Selection.ParagraphFormat

.LeftIndent = CentimetersToPoints(0)

.RightIndent = CentimetersToPoints(0)

.SpaceBefore = 10

.SpaceBeforeAuto = False

.SpaceAfter = 0

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceMultiple

.LineSpacing = LinesToPoints(1.1)

.WidowControl = True

.KeepWithNext = False

.KeepTogether = False

.PageBreakBefore = False

.NoLineNumber = True

.Hyphenation = True

.FirstLineIndent = CentimetersToPoints(0)

.OutlineLevel = wdOutlineLevelBodyText

.CharacterUnitLeftIndent = 0

.CharacterUnitRightIndent = 0

.CharacterUnitFirstLineIndent = 0

.LineUnitBefore = 0

.LineUnitAfter = 0

.MirrorIndents = False

.TextboxTightWrap = wdTightNone

.CollapsedByDefault = False

.ReadingOrder = wdReadingOrderLtr

End With

End Sub

'''''''''''''''''''''''' TABLES ''''''''''''''''''''''''

'Following formats table (in which cursor is placed):

Sub FormatTable()

If Selection.Information(wdWithInTable) = False Then

MsgBox "Table not found. " & vbNewLine & vbNewLine & "Cursor/Selection must be within a table.", vbInformation, "Format Table"

End

End If

'Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)

Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)

Selection.Tables(1).Style = "Table Grid Light"

Call LineSpacing1_3

End Sub

'Following sub converts tab delimitted lines into a table:

Sub TabsToTable()

'Check if cursor is in existing table:

If Selection.Information(wdWithInTable) = True Then

MsgBox "Table already exists" & vbNewLine & vbNewLine & " OR" & vbNewLine & vbNewLine & "You have selected a Table (instead of set of tab separated values)", vbOKOnly & vbCritical, "Curson in Table"

Exit Sub

End If

'Check if text is selected:

If Not (Selection.Type <> wdSelectionIP) Then

MsgBox "Text not selected." & vbNewLine & vbNewLine & "Please select (set of) tab separated values to convert/format them in to a table.", vbOKOnly & vbExclamation, "Selection not found"

Exit Sub

End If

'Convert Tabs to Table:

Selection.ConvertToTable Separator:=wdSeparateByTabs, AutoFitBehavior:=wdAutoFitFixed

With Selection.Tables(1)

'.Style = "Table Grid"

.Style = "Table Grid Light"

.ApplyStyleHeadingRows = True

.ApplyStyleLastRow = False

.ApplyStyleFirstColumn = True

.ApplyStyleLastColumn = False

'.AutoFitBehavior (wdAutoFitContent)

.Rows(1).Select 'Select 1st Row

End With

Selection.Font.Bold = wdToggle 'Bold selected values (in row)

Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'Centre selected values

'Indent entire table:

Selection.Tables(1).Select

Selection.Paragraphs.Indent

Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)

End Sub

'''''''''''''''''''''''' HIGHLIGHTING ''''''''''''''''''''''''

'Ver5: (EdChoice) Excludes all non-alphabets & certain words stored in Array elements,

'this array eliminates the need for writing long IF statement comparing each excluded word.

'Also removes boldness from selection, this is important for consistent result.

Sub Highlight1stCharacter()

'Dim cnt As Integer: cnt = Selection.Words.Count ' Not accurate as count includes punctuations & carriage returns signs.

Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.

If cnt <= 0 Then

MsgBox "Nothing selected, please select word(s) to highlight its first letter{(s)."

End

End If

Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp") 'using Late Binding. 'Dim regEx As New RegExp 'requires Early Binding

regEx.Pattern = "[a-zA-Z]" 'requires: VBE>Tools>Reference: "Microsoft VBScript Regular Expressions 5.5".

Dim excl() As String

excl() = Split("and, of, for, to, with, in, on, a, an, the", ", ") 'One-liner array assignment.

'remove boldness from selection, this is important for consistent result:

Selection.Font.Bold = False

'move (without wdExtend) cursor to the left/beginning of the selection:

Selection.MoveLeft Unit:=wdCharacter, Count:=1

'running a loop to select the 1st character then highlight it:

'For Each w In Selection.Words 'this won't work here as we need to alter the Words in selection.

For i = 1 To cnt

Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'select single word

'MsgBox (Selection) 'check which word

'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))

'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.

For Each x In excl

'If (InStr(Selection, x & " ") > 0) Then 'doesn't work as searches x inString of Selection.

If LCase(Trim(Selection)) = x Then

Selection.MoveRight Unit:=wdWord, Count:=1

GoTo NextIteration

End If

Next x

'above array-iteration replaces need of following Loooooong if statement:

'If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0 Or InStr(Selection, "to ") > 0) Then

Selection.MoveLeft Unit:=wdWord, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'check if selected character is an alphabet:

If (regEx.test(Selection)) Then

'Selection.Font.Bold = True

Selection.Font.Bold = wdToggle

Selection.Range.Case = wdUpperCase

End If

Selection.MoveRight Unit:=wdWord, Count:=1

NextIteration:

Next i

End Sub

'ProperCase by macro

Sub Caps1stChar()

'This will convert the case of the first letter of selection into uppercase.

Dim txt As String

txt = ""

For i = 1 To Selection.Words.Count

txt = txt & StrConv(Selection.Words(i), vbProperCase)

Next i

Selection.Text = txt

End Sub

'Following sub highlights/bolds the first part for each sentence (in selection) till colon (:), useful for "list with highlighted topics":

Sub BoldTopicsInList()

Dim lineCount As Integer: lineCount = Selection.Paragraphs.Count

Dim currentPosition As Range

Set currentPosition = Selection.Range 'record current selection / cursor position

Selection.Font.Bold = False 'remove bold from entire selection (for consistent result)

Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.

If cnt <= 0 Then

MsgBox "Nothing selected, please select line(s) to highlight its topic separated by a colon (:)."

End

End If

'For Each p In Selection.Paragraphs

For i = 1 To lineCount

Selection.HomeKey Unit:=wdLine

Selection.EndKey Unit:=wdLine, Extend:=wdExtend

linetext = Selection.Range.Text

idx = InStr(linetext, ":")

If idx <= 0 Or Selection.Characters(idx + 1).Text = "\" Then

GoTo NextIteration

End If

idx = idx - 1

Selection.HomeKey Unit:=wdLine

Selection.MoveRight Unit:=wdCharacter, Count:=idx, Extend:=wdExtend 'select chars till colon

Selection.Font.Bold = True 'Selection.Style = ActiveDocument.Styles("Code highlighted")

NextIteration:

Selection.MoveDown Unit:=wdParagraph, Count:=1 ' move cursor to next paragraph without extending selection.

Next i

currentPosition.Select 'return cursor/selection back to original position.

End Sub

'Following sub highlights the part for each sentence (in selection) till colon (:), useful for "creating a list with highlighted (command-line) Commands":

Sub HighlightCodeTillColon()

Dim lineCount As Integer: lineCount = Selection.Paragraphs.Count

Dim currentPosition As Range

Set currentPosition = Selection.Range 'record current selection / cursor position

Selection.Font.Bold = False 'remove bold from entire selection (for consistent result)

Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.

If cnt <= 0 Then

MsgBox "Nothing selected, please select line(s) to highlight its topic separated by a colon (:)."

End

End If

'For Each p In Selection.Paragraphs

For i = 1 To lineCount

Selection.HomeKey Unit:=wdLine

Selection.EndKey Unit:=wdLine, Extend:=wdExtend

linetext = Selection.Range.Text

idx = InStr(linetext, ":")

If idx <= 0 Then

GoTo NextIteration

End If

idx = idx - 1

Selection.HomeKey Unit:=wdLine

Selection.MoveRight Unit:=wdCharacter, Count:=idx, Extend:=wdExtend 'select chars till colon

Selection.Style = ActiveDocument.Styles("Code highlighted") 'Selection.Font.Bold = True

'Selection.Style = ActiveDocument.Styles("Code with Background") '"Code highlighted" 'Selection.Font.Bold = True

Selection.NoProofing = True

NextIteration:

Selection.MoveDown Unit:=wdParagraph, Count:=1 ' move cursor to next paragraph without extending selection.

Next i

currentPosition.Select 'return cursor/selection back to original position.

End Sub

'''''''''''''''''''''''' HEADERS ''''''''''''''''''''''''

Sub SetHeading4()

Selection.Style = ActiveDocument.Styles("Heading 4")

End Sub

Sub SetHeading5()

Selection.Style = ActiveDocument.Styles("Heading 5")

End Sub

'''''''''''''''''''''''''Ed-Utilities''''''''''''''''''''

'Following is used for IT-Training Invoice generation via VBA-Form:

Sub WriteSequenceFile()

System.PrivateProfileString("C:\test\id_sequence.txt", "id_sequence", "id") = 1001

End Sub

'Paste as plain text / Paste unformatted text / Paste as Template Text:

Sub PasteAsUnformattedText()

On Error GoTo ErrHndl

Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False

GoTo Done

ErrHndl:

Select Case Err.Number ' Evaluate error number.

Case 4198 '4198 is usually an unknown/generic error.

Case 4605 '4605 mothod/property is not available because Clipboard is empty or not valid.

MsgBox "Clipboard empty: Nothing to paste.", vbInformation, "Empty Clipboard"

GoTo Done

Case 5342 '5342 is usually when non-textual (pic/audio/video) is in clipboard, so obviously can't be pasted as text.

MsgBox "A non-textual object (such as picture/audio/video) is found/copied to the Clipboard, which can't be pasted as text." _

& vbNewLine & vbNewLine & "Copy text only then try again.", vbInformation, "Non-Textual Object"

GoTo Done

Case Else

MsgBox "Error# " & Err.Number & " : " & Err.Description

On Error GoTo Unicode

End Select

Unicode:

Selection.PasteAndFormat (wdFormatPlainText)

Done:

End Sub

'Following sub converts currently selected text into a hyperlink to "7IM Jira + current selection":

'e.g.: SPP-6415 (as long as text is selected) it will become a link to Editable-Jira ("https://canadalife.atlassian.net/browse/SPP-6415")

'Ctrl+Shift+Alt + L: (L for Link):

Sub eq_JiraLinkFromSelection()

Dim jirano As String: jirano = Selection.Text

Let jirano = UCase(jirano)

ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _

Address:="https://7imhelpdesk.atlassian.net/browse/" & jirano, _

SubAddress:="", ScreenTip:="7IM Jira Link/URL", TextToDisplay:=jirano

End Sub

'Following sub converts currently selected text into a hyperlink to "7IM Read-only-Jira + current selection":

'e.g.: RFC-1514 (as long as text is selected) it will become a link to Read-only-Jira ("https://7imhelpdesk.atlassian.net/servicedesk/customer/portal/6/RFC-1514")

'Ctrl+Shift+Alt + J: (J for Jira):

Sub eq_ReadOnlyJiraLinkFromSelection()

Dim jirano As String

Let jirano = Selection.Text

Let jirano = UCase(jirano)

ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _

Address:="https://7imhelpdesk.atlassian.net/servicedesk/customer/portal/6/" & jirano, _

SubAddress:="", ScreenTip:="7IM Jira Link/URL", TextToDisplay:=jirano

End Sub

'Following sub converts currently selected text into a hyperlink to "7IM Bug + current selection":

'e.g.: 95545 to become: "http://itdevtfs1:8080/tfs/DefaultCollection/Live%20Bugs/_workitems/edit/95545"

'New: 100975 to become: https://azuredevops.7im.co.uk/DefaultCollection/Projects/_workitems/edit/100975

'Ctrl+Shift+Alt + K: (K for worK item):

Sub eq_7IMBugFromSelection()

Dim jirano As String

Let jirano = Selection.Text

Let jirano = UCase(jirano)

ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _

Address:="https://azuredevops.7im.co.uk/DefaultCollection/Projects/_workitems/edit/" & jirano, _

SubAddress:="", ScreenTip:="7IM DevOps Project-WorkItem OR Bug link/URL", TextToDisplay:=jirano

'ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _

'Address:="http://itdevtfs1:8080/tfs/DefaultCollection/Live%20Bugs/_workitems/edit/" & jirano, _

'SubAddress:="", ScreenTip:="7IM DevOps Bug Link/URL", TextToDisplay:=jirano

End Sub

''''''''''''''''''''''''Ed-VBA-Reusable-Code-Assist''''''''''''''''''''''''

'Following code clears the Immediate window pane:

Sub FlushImmediateWindow()

'Debug.Print VBA.String(200, vbNewLine) 'flush its content instead of SnedKeys

SendKeys "^{g}", False

DoEvents

SendKeys "^{Home}", False

SendKeys "^+{End}", False

SendKeys "{Del}", False

SendKeys "{F7}", False

End Sub

Sub ConfirmRun(subName)

Dim ans As String

ans = MsgBox("Would you like to continue with """ & subName & """", vbYesNo, "Confirm Execution")

If ans = vbNo Then

End

End If

End Sub

'''''''''''''''''''''''' Export-Utilities ''''''''''''''''''''''''

'Following module instantly/silently exports the existing document as as PDF - placing it in the current folder of source file (or if unsaved, on the current-user's Desktop):

Sub ExportAsPDF()

Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")

Dim pathToDesktop As String

pathToDesktop = wsh.SpecialFolders("Desktop")

Dim docPath As String

If Len(ActiveDocument.Path) <= 0 Or ActiveDocument.Path Like "http*" Then ' Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##"

docPath = pathToDesktop '"C:\temp" 'alternatively use netowrk UNC path.

'docPath = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\temp" '-> returns customised Documents folder (not the User Document folder.)

Else

docPath = ActiveDocument.Path

End If

'If ActiveDocument.Path Like "http*" Then

' docPath = docPath & "/"

'Else

' docPath = docPath & "\"

'End If

docPath = docPath & "\"

Debug.Print docPath

Dim docName As String: docName = ActiveDocument.Name

'docName = docName & "_" & Format(Now, "dd-MM-yyyy_hhnnss") & ".pdf"

Dim fileExt As String: fileExt = Right(docName, 5)

If fileExt = ".docx" Then

docName = Replace(docName, fileExt, ".pdf")

Else

docName = docName & "_" & Format(Now, "dd-MM-yyyy_hhnnss") & ".pdf"

End If

ChangeFileOpenDirectory docPath

ActiveDocument.ExportAsFixedFormat OutputFileName:=docName, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, _

OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _

IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _

BitmapMissingFonts:=True, UseISO19005_1:=False

MsgBox "Document exported as: """ & docName & """" & vbNewLine & vbNewLine & "Saved under: " & docPath

End Sub

'Following module instantly/silently saves/exports the existing document as standard Docx - placing it in the current folder

'of the source file (or if unsaved, places the file into the "C:\Temp\" folder / on the current-user's Desktop):

Sub SaveAsDocx()

Dim docPath As String

If Len(ActiveDocument.Path) <= 0 Or ActiveDocument.Path Like "http*" Then ' Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##"

docPath = "C:\temp" 'alternatively use netowrk UNC path.

'Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")

'Dim pathToDesktop As String: pathToDesktop = wsh.SpecialFolders("Desktop")

'pathToDesktop = wsh.SpecialFolders("Desktop")

'docPath = pathToDesktop

'docPath = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\temp" '-> returns customised Documents folder (not the User Document folder.)

Else

docPath = ActiveDocument.Path

End If

'If ActiveDocument.Path Like "http*" Then

' docPath = docPath & "/"

'Else

' docPath = docPath & "\"

'End If

docPath = docPath & "\"

'Debug.Print docPath

Dim docName As String: docName = ActiveDocument.Name

'Debug.Print docName '=> "Document1" if unsaved.

Dim selectedText As String: selectedText = Selection.Text

'If docName = "Document1" Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##" Then

'Debug.Print Len(Trim(selectedText)) '"1" if nothing/no text is selected.

If Len(selectedText) > 1 Then

selectedText = Replace(selectedText, vbCr, "")

docName = selectedText

End If

docName = docName & "_" & Format(Now, "yyyy-MM-dd_hhnnss") & ".docx"

Debug.Print docName '=> "Document1_2023-08-08_103958.docx" if unsaved.

ChangeFileOpenDirectory docPath

ActiveDocument.SaveAs2 FileName:=docName, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _

AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _

SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False ', CompatibilityMode:=15

MsgBox "Document saved as: """ & docName & """" & vbNewLine & vbNewLine & "Placed under: " & docPath

End Sub

'''''''''''''''''''''''''''Ed-Useful-VBA-Code-Sample'''''''''''''''''''''''''

'Following removes the matching RegExp-pattern from each (selected) paragraph/line(s):

Sub ReplaceSomeTextUsingRegExp()

Set strSource = Application.Selection

If Len(strSource) <= 1 Then

MsgBox "Nothing selected." & vbNewLine & _

"Select paragraphs from which matching RegExp-pattern needs to be removed."

End

End If

pat = "[0-9]{1,2}\.\s" 'remove line-number.

Set regEx = CreateObject("VBScript.RegExp") 'Late binding

With regEx

.Pattern = pat

.IgnoreCase = True

.Global = True

.MultiLine = True

End With

If regEx.test(s) Then

Debug.Print (regEx.Replace(strSource, ""))

Else

Debug.Print ("No match found (for specified Pattern)")

End If

End Sub ' "12. Some text" => "Some text" if pattern is: "[0-9]{1,2}\.\s"

Sub EmptyParagraphsCount()

Dim selRng As Range: Set selRng = Selection.Range

Dim paras As Paragraphs: Set paras = selRng.Paragraphs

Dim cnt As Integer: cnt = 0

'For Each tempTable In ActiveDocument.Paragraphs

For Each para In paras

If Len(para.Range.Text) = 1 Then 'para.Range.Editors.Add wdEditorEveryone

cnt = cnt + 1

End If

Debug.Print cnt

End Sub

Sub ParseSentenceInEachParagraph()

Dim paras As Paragraphs

Dim para As Paragraph

Dim sents As Sentences

Dim paraText As String

Dim sent As Range

Dim selRng As Range: Set selRng = Selection.Range

Set paras = selRng.Paragraphs 'for selection only

'Set paras = ActiveDocument.Paragraphs 'for whole document

For Each para In paras

paraText = Len(Trim(para.Range.Text))

If (paraText > 1) Then '1 new-line char is always present in each paragraph.

Set sents = para.Range.Sentences

For Each sent In sents

Debug.Print (sent.Text)

End If

End Sub

Sub RangeSelectionTest()

Dim rng As Range

Set rng = ActiveDocument.Range(Start:=1, End:=3)

rng.Select

Selection.Font.Bold = True

End Sub

Sub CatchSpecificError()

On Error GoTo ErrorHandler ' Enable error-handling routine.

Dim i As Integer

i = 2 / 0 ' Divide by ZERO Error Raises

ErrorHandler: ' Error-handling routine.

Select Case Err.Number ' Evaluate error number.

Case 11 ' Divide by zero error

MsgBox ("You attempted to divide by zero!")

Case Else

MsgBox "Unknown Error- Error# " & Err.Number & " : " & Err.Description

End Select

End Sub

'Following function allows you to both read from the clipboard and write to the

' clipboard depending on if you pass string value to the parameter:

Function Clipboard(Optional StoreText As String) As String

'PURPOSE: Read/Write to Clipboard

'Source: ExcelHero.com (Daniel Ferry)

Dim x As Variant

'Store as variant for 64-bit VBA support

x = StoreText

'Create HTMLFile Object

With CreateObject("htmlfile")

With .parentWindow.clipboardData

Select Case True

Case Len(StoreText)

'Write to the clipboard

.setData "text", x

Case Else

'Read from the clipboard (no variable passed through)

Clipboard = .GetData("text")

End Select

End With

End Function

Sub ClipboardTest()

'Usage:

'Copy text to the clipboard:

Clipboard ("This will be copied to the Clipboard!")

'To read text from the clipboard:

MsgBox Clipboard

End Sub

'Displays the path of current file and copies it to the clipboard:

Sub getPathCurrentFile()

If Len(ActiveDocument.Path) <= 0 Then

docPath = "Unsaved Document!"

Else

docPath = ActiveDocument.Path

End If

x = CStr(docPath & "\" & ActiveDocument.Name)

Clipboard (x)

MsgBox docPath & vbNewLine & vbNewLine & ActiveDocument.Name

'MsgBox "_" & Format(Now, "dd-MM-yyyy_hhnnss")

End Sub

Sub GetPathsOfCurrentFileWordBinaryAndMyDoc()

Dim strPath As String

strPath = ThisDocument.FullName

strPath1 = ThisDocument.Path 'same as: & "CurDir"

strName = ThisDocument.Name

strCurDir = Application.Path

myDocDir = CreateObject("WScript.Shell").SpecialFolders("mydocuments") '-> returns customised Documents folder (not the User Document folder.)

'MsgBox (strName & vbNewLine & vbNewLine & strPath1 & vbNewLine & vbNewLine & strPath & vbNewLine & vbNewLine & strCurDir & vbNewLine & vbNewLine & myDocDir)

MsgBox ("File Name: " & strName & vbNewLine & vbNewLine & "File Path: " & strPath1 & vbNewLine & vbNewLine)

End Sub

Sub getUserDesktopPath()

'WSh - Early binding:

'Dim wsh As WshShell: Set wsh = New WshShell

'MsgBox wsh.SpecialFolders("Desktop") 'MyDocuments

'WSh - Late binding:

Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")

MsgBox wsh.SpecialFolders("Desktop")

End Sub

'------------ x -------------

List of some of my IT blogs:

List of my other blogs:

Steps to heal tennis elbow

Thursday, 19 November 2015

Useful VBA Utilities for Microsoft Excel & Data Handling

Author: Eddie Shrivastava

In recent years, whilst working on a various Data-projects (Data Engineering, Data Analysis and Data Warehouse projects) as a DBA/Data Engineer, I noticed that whilst for handling large datasets it's better to use specific technologies such as: SSIS, PowerShell, T-SQL etc. however, for smaller datasets, Excel is sill handy (in 2021) for some quick data transformations. Considering this, I made use of good old Excel VBA / Macros, which turned out to be very useful and time saving, therefore, I would like to share some of my code snippets especially the ones that are generic in nature i.e. they can be re-used in diverse scenarios and can be useful for other Data professionals. I'm happy for my code to be re-used (without any attached strings of licences).

VBA Code Templates & Samples:

' Following code converts a number written as words/alphabets (e.g. One, Two) into digits as 1 to 9
Function GetDigit(WordedNumber)
WordedNumber = WorksheetFunction.Proper(WordedNumber) 'important for consistent results.
Select Case WordedNumber
Case "One", "0ne": GetDigit = 1
Case "Two", "Tw0": GetDigit = 2
Case "Three": GetDigit = 3
Case "Four": GetDigit = 4
Case "Five": GetDigit = 5
Case "Six": GetDigit = 6
Case "Seven": GetDigit = 7
Case "Eight": GetDigit = 8
Case "Nine": GetDigit = 9
Case "Ten": GetDigit = 10
Case "Eleven": GetDigit = 11
Case "Twelve": GetDigit = 12
Case "Thirteen": GetDigit = 13
Case "Fourteen": GetDigit = 14
Case "Fifteen": GetDigit = 15
Case "Sixteen": GetDigit = 16
Case "Seventeen": GetDigit = 17
Case "Eighteen": GetDigit = 18
Case "Nineteen": GetDigit = 19
Case "Twenty": GetDigit = 20
Case Else: GetDigit = ""
End Select
End Function

' Following code converts digits as 1 to 9 into number written as words/alphabets.

Function GetWordedNumbers(Digit)
Select Case Val(Digit)
Case 1: GetWordedNumbers = "One"
Case 2: GetWordedNumbers = "Two"
Case 3: GetWordedNumbers = "Three"
Case 4: GetWordedNumbers = "Four"
Case 5: GetWordedNumbers = "Five"
Case 6: GetWordedNumbers = "Six"
Case 7: GetWordedNumbers = "Seven"
Case 8: GetWordedNumbers = "Eight"
Case 9: GetWordedNumbers = "Nine"
Case 10: GetWordedNumbers = "Ten"
Case 11: GetWordedNumbers = "Eleven"
Case 12: GetWordedNumbers = "Twelve"
Case 13: GetWordedNumbers = "Thirteen"
Case 14: GetWordedNumbers = "Fourteen"
Case 15: GetWordedNumbers = "Fifteen"
Case 16: GetWordedNumbers = "Sixteen"
Case 17: GetWordedNumbers = "Seventeen"
Case 18: GetWordedNumbers = "Eighteen"
Case 19: GetWordedNumbers = "Nineteen"
Case 20: GetWordedNumbers = "Twenty"
Case Else: GetWordedNumbers = ""
End Select
End Function

Looping through Objects:

Looping through Workbooks / Excel Files:

Example-1:

'following code loops through workbooks

'following code loops through all OPEN workbooks then displays those book-names:

Sub LoopingThroughBooks()

For Each book In Workbooks

Text = Text & book.Name & vbNewLine

Next book

MsgBox Text

End Sub

Looping through Sheets:

Example-1:

'following code loops through worksheets in current workbook then displays those sheet-names:

Sub LoopingThroughSheets()

For Each sheet In Worksheets

Text = Text & sheet.Name & vbNewLine

Next sheet

MsgBox Text

End Sub

Looping through Columns or Rows:

Example-0: looping through Rows

'Following code loops through the 1st row to the last row:

Sub LoopingRows()

Dim LastRow As Long, r As Long

'LastRow = ActiveSheet.UsedRange.Rows.Count

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

For r = 1 To LastRow

' Your code here

Next r

End Sub

Example-1:

'First find out the last row / column then simply do a counter-loop:

Sub UsedRangeColsRows()

Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long

LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row

LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column

LastColCount = ActiveSheet.UsedRange.Columns.Count

Debug.Print LastRow

Debug.Print LastCol & " which is same as " & LastColCount

For c = 1 To LastCol

For r = 1 To LastRow

If Cells(r, c) = "MyCheck" Then

' Your code here

End If

Next r

Next c

End Sub

Example-2:

'This code loops through & hides all columns except column-headers written in the 'arr' array.

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub HideCols()

Dim arr As Variant 'arr must Variant or String type as Range() & Split() return Sub-Strings (array).

Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long

arr = Split("1.8 Station Ground of Incident, 2.1 Time of call, 3.2 Property Type", ", ")

LastCol = ActiveSheet.UsedRange.Columns.Count

For c = 1 To LastCol

'If Cells(1, c) = "MyValueCheck" Then

If (IsInArray(Cells(1, c), arr)) Then

Cells(1, c).EntireColumn.Hidden = False

Else

Debug.Print "Hiding: " & Cells(1, c).Value

Cells(1, c).EntireColumn.Hidden = True

End If

Next c

End Sub

Example-3:

'This code loops through & deletes all columns except column-headers written in the 'arr' array.

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub DeleteCols()

Dim arr As Variant 'arr must Variant or String type as Range() & Split() return Sub-Strings (array).

Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long

arr = Split("1.1 FRS Incident Number, 1.8 Station Ground of Incident, 2.1 Time of call, 3.2 Property Type, 4.3a X-Coordinate, 4.3b Y-Coordinate, 5.15 Cause/motive, Textual_Address, Fire Classification", ", ")

For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1

If Not (IsInArray(Cells(1, c), arr)) Then

Cells(1, c).EntireColumn.Delete

End If

Next c

End Sub

Sorting Array Elements in VBA

VBA has no built-in support for sorting the values stored in an array. One method that can be used to sort arrays is to put the data back on to a worksheet, sort the data on the worksheet, and then read back the values from the worksheet into the array. The second method for sorting arrays is to use any simple sort algorithm (such as Bubble sorting) to sort the array in place.

Method-1: Sorting by writing on Worksheet - sorting data then - read back into array:

Sub SortViaWorksheet()

Dim arr() As String ' this is the array to be sorted

Dim WS As Worksheet ' temporary worksheet

Dim R As Range

Dim N As Long

' populating array

arr = Split("zzz, aaa, nnn, ppp, bbb", ", ")

'Debug.Print Join(arr, "; ")

Application.ScreenUpdating = False

' create a new sheet

Set WS = ThisWorkbook.Worksheets.Add

' put the array values on the worksheet

Set R = WS.Range("A1").Resize(UBound(arr) - LBound(arr) + 1, 1)

R = Application.Transpose(arr)

' sort the range

R.Sort key1:=R, order1:=xlAscending, MatchCase:=False

' load the worksheet values back into the array

'Erase arr 'Erase purges all elements & resizes array to 0, hence ReDim/Split() will be required.

For N = 1 To R.Rows.Count

arr(N - 1) = R(N, 1) 'N-1 because index starts with 0.

Next N

' delete the temporary sheet

Application.DisplayAlerts = False

WS.Delete

Application.DisplayAlerts = True

Application.ScreenUpdating = True

' test/debug/confirmation

MsgBox Join(arr, ", ")

For N = LBound(arr) To UBound(arr)

Debug.Print arr(N)

Next N

End Sub

Method-2: Sorting using manual sort: (bubble sort or quick sort)

Bubble sort implementation:

'Two ways to call following BubbleSort() sub:

' BubbleSort yourArrayName or

' Call BubbleSort(yourArrayName)

Sub BubbleSort(arr)

Dim strTemp As String

Dim i As Long

Dim j As Long

Dim lngMin As Long: lngMin = LBound(arr)

Dim lngMax As Long: lngMax = UBound(arr) -1

For i = lngMin To lngMax

For j = i + 1 To lngMax

If arr(i) > arr(j) Then 'for Descending order: If arr(i) < arr(j) Then

strTemp = arr(i)

arr(i) = arr(j)

arr(j) = strTemp

End If

Next j

Next i

End Sub

Quick sort implementation:

Sub QuickSort(arr, Lo As Long, Hi As Long)

Dim varPivot As Variant

Dim varTmp As Variant

Dim tmpLow As Long

Dim tmpHi As Long

tmpLow = Lo

tmpHi = Hi

varPivot = arr((Lo + Hi) \ 2)

Do While tmpLow <= tmpHi

Do While arr(tmpLow) < varPivot And tmpLow < Hi

tmpLow = tmpLow + 1

Loop

Do While varPivot < arr(tmpHi) And tmpHi > Lo

tmpHi = tmpHi - 1

Loop

If tmpLow <= tmpHi Then

varTmp = arr(tmpLow)

arr(tmpLow) = arr(tmpHi)

arr(tmpHi) = varTmp

tmpLow = tmpLow + 1

tmpHi = tmpHi - 1

End If

Loop

If Lo < tmpHi Then QuickSort arr, Lo, tmpHi

If tmpLow < Hi Then QuickSort arr, tmpLow, Hi

End Sub

Use above like this:

QuickSort MyArray, LBound(MyArray), UBound(MyArray)

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Another Bubble sort example (for both Ascending & Descending orders):

Option Explicit

Sub SortArray()

Dim MyArray As Variant, i As Long

MyArray = Array(1, 4, 2, 32, 5, 21)

' True being sort as Ascending. False will sort Descending.

MyArray = BubbleSrt(MyArray, True)

For i = LBound(MyArray) To UBound(MyArray)

MsgBox MyArray(i)

Next i

End Sub

Public Function BubbleSrt(ArrayIn, Ascending As Boolean)

' True being sort as Ascending. False will sort Descending.

Dim SrtTemp As Variant

Dim i As Long

Dim j As Long

If Ascending = True Then

For i = LBound(ArrayIn) To UBound(ArrayIn)

For j = i + 1 To UBound(ArrayIn)

If ArrayIn(i) > ArrayIn(j) Then

SrtTemp = ArrayIn(j)

ArrayIn(j) = ArrayIn(i)

ArrayIn(i) = SrtTemp

End If

Next j

Next i

Else

For i = LBound(ArrayIn) To UBound(ArrayIn)

For j = i + 1 To UBound(ArrayIn)

If ArrayIn(i) < ArrayIn(j) Then

SrtTemp = ArrayIn(j)

ArrayIn(j) = ArrayIn(i)

ArrayIn(i) = SrtTemp

End If

Next j

Next i

End If

BubbleSrt = ArrayIn

End Function

Deleting empty columns

Example-1:

This code deletes all empty columns in ActiveSheet (only):

Sub DeleteEmptyColumns()

'Application.ScreenUpdating = False 'Application can be omitted as object assumed in VBE

ScreenUpdating = False

'Debug.Print ActiveSheet.UsedRange.Columns.Count

For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1

'Debug.Print WorksheetFunction.CountA(Columns(i))

If WorksheetFunction.CountA(Columns(i)) = 0 Then

Columns(i).Delete

End If

ScreenUpdating = True

End Sub

Example-2:

'This code loops through all sheets and deletes any empty columns:

Sub LoopingThroughSheets()

Dim Text As String

ScreenUpdating = False

For Each Sheet In Worksheets

Text = Text & Sheet.Name & vbNewLine

Sheet.Select

For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1

'Debug.Print WorksheetFunction.CountA(Columns(i))

If WorksheetFunction.CountA(Columns(i)) = 0 Then

Columns(i).Delete

End If

Next i

Next Sheet

ScreenUpdating = True

MsgBox Text

End Sub

Counting a word in a column:

Sub CountBonfire()

Dim lRow As Long 'last row (of table)

Dim str1, str2 As String 'strings to search

Dim cnt As Integer: cnt = 0 'count number of findings

lRow = ActiveSheet.Range("GP" & ActiveSheet.Rows.Count).End(xlUp).Row 'MsgBox lRow

str1 = "BONFIRE"

str2 = UCase("Controlled burning")

'str3 = UCase("")

For Each cell In Range("AM1:AM" & lRow)

'Set wcf = Range("d1").Find(cell.Value)

'Above is ok if exact value matches in range - Not for <= or >= comparisons.

If (InStr(UCase(cell.Value), str1)) <> 0 Or InStr(UCase(cell.Value), str2) <> 0 Then

'MsgBox cell.Row '_ Exit For

'MsgBox ActiveSheet.Range("GN" & cell.Row).Value

'If (InStr(UCase(ActiveSheet.Range("GN" & cell.Row).Value), UCase("overborder"))) = 0 Then

'Exit For

cnt = cnt + 1

'End If

End If

Next cell

MsgBox cnt

End Sub

Finding a date in a range of dates:

Following VBA code takes the cursor (as Goto command) to the current week (Assumption: Worksheet contains a column listing weekly-dates (here A1:A300)).

Note: One of the easiest way to compare dates in VBA is to convert them into long values using CLng() function, see used in the example below.

Sub curr_week()

Dim cell As Range, _

wcf As Range

Dim today As Long 'must compare dates in Long & Date+Time or just Time in Double otherwise problematic.

today = CLng(Date) 'converting current date into Long.

For Each cell In Range("A1:A300")

'Set wcf = Range("d1").Find(cell.Value)

'Above is ok if exact value matches in range - Not for <= or >= comparisons.

If IsDate(cell.Value) And Not IsEmpty(cell.Value) Then

If today >= CLng(cell.Value) And today < CLng(cell.Offset(1, 0).Value) Then

Set wcf = cell

End If

Next cell

If Not wcf Is Nothing Then

Debug.Print wcf.Value 'Ctrl+G to open Immediate window where Debug-stmts print.

Application.Goto wcf, True 'Application.Goto requires a range.

Else

MsgBox "Date range not found, Eddie to check Macro."

End If

End Sub

Changing cell's background colour-shade to highlighting certain data (used in Data Analysis):

Method - 1: using Excel's Conditional Formatting -> Data Bars / Icon Sets OR Colour Scales.

Colouring a range - using Interior.Color property:

Range("A1").Interior.Color = RGB(255, 0, 0) 'using RGB function

Range("A1").Interior.ColorIndex = 37 'using ColorIndex

Setting background color to 'No Fill':

Range("A1").Interior.ColorIndex = 0

Displaying ColorIndex

MsgBox Selection.Interior.ColorIndex

Method - 2: using VBA Code.

Sub HighlihgtCellsAsPerValue()

Dim maxval As Integer, rng As Range, cell As Range

Set rng = Range("e4:g16") 'SET is mandatory as we are assigning a reference (not literal value/LET).

For Each cell In rng

cell.Value = WorksheetFunction.RandBetween(100, 999) 'filling cells with random values for test.

maxval = WorksheetFunction.Max(rng)

'Debug.Print ((9 / 255) * maxval)

For Each cell In rng

'cell.Interior.Color = RGB(255, 255 - (cell.Value * 255 / maxval), 255 - (cell.Value * 255 / maxval))

'above makes colours too dark, even though logically more correct.

cell.Interior.Color = RGB(255, 255 - (cell.Value * 80 / maxval), 255 - (cell.Value * 80 / maxval))

End Sub

Searching & highlighting matching values from two ranges (using Array from a Range):

Ver-1 Requires: two ranges in column B, file: ArrayFromRange_RowHide.xlsm.

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub FindMatchingValsFromOtherRange()

Dim rng, cell As Range: Set rng = Range("b1:b39")

Dim arr() As Variant 'arr must Variant or String type as Range() & Split() return Sub-Strings (array).

'arr() = Split("Essex, Berkshire, Dorset, Durham", ", ") 'manual array - without using range.

arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).

'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).

'Application.SendKeys "^g ^g ^a {DEL} {F7}" 'Clearing Immediate/Debug-output window.

Debug.Print Now

'Debug.Print Join(arr, ", ")

For Each cell In rng

If (IsInArray(cell.Value, arr)) Then

cell.Interior.Color = vbRed 'Highlight cell.

'cell.EntireRow.Hidden = True 'Hide EntireRow.

End If

Next cell

End Sub

Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-2 Requires alteration in code below: define a range (38 cells) in column B, code then asks user to continue to hide rows. file: "CIPFA Stats 2014-15.xlsm".

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub HideOtherGroups()

Dim rngAllStns, cell As Range

Dim totArrElems As Integer: totArrElems = 0

Dim arr As Variant

Set rngAllStns = Range("b6:b43")

rngAllStns.Select

ContiExec = MsgBox("Are you happy with selected cells, continue hiding row?", vbOKCancel + vbQuestion)

If ContiExec = vbCancel Then 'incorrect selection of cells - exit sub

Exit Sub

End If

arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",") 'manual array - without using range.

'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1

'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).

'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).

'Application.SendKeys "^g ^g ^a {DEL} {F7}" 'Clears Immediate/Debug-output window.

Debug.Print Now

'Debug.Print Join(arr, ", ")

rngAllStns.EntireRow.Hidden = True

For Each cell In rngAllStns

If (IsInArray(cell.Value, arr)) Then

cell.EntireRow.Hidden = False

totArrElems = totArrElems + 1

End If

Next cell

MsgBox "Total count of visible rows: " & totArrElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count

End Sub

Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows, also now limited (500) row search, uses Goto() instead of Cells(). File: "CIPFA Stats 2014-15.xlsm".

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub HideOtherGroups()

'Search & hide all rows except matching values from a set of values (stored in an Array):

'Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows., file: "CIPFA Stats 2014-15.xlsm".

Dim rngAllStns, cell As Range

Dim totArrElems As Integer: totArrElems = 0

Dim arr As Variant 'arr must Variant or String type as Range() & Split() return Sub-Strings (array).

'Set rngAllStns = Range("b6:b43") 'reading source-data from sheet/range (instead of VBA code/array)

'Cells(1, 2).Select 'OR ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()

Application.GoTo ActiveSheet.Range("B1"), True

'MsgBox ActiveCell.Address

Do While ActiveCell.Row < 500

ActiveCell.Offset(1, 0).Select

If (ActiveCell.Value = "Avon") Then

Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(37, 0)) 'Offset doesn't count current cell.

Exit Do

End If

Loop

rngAllStns.Select

ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & " - Continue hiding row?", vbYesNo + vbQuestion)

If ContiExec = vbNo Then 'incorrect selection of cells - exit sub

Exit Sub

End If

'Manually storing stations in array - not reading from range on sheet:

arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",")

'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1

'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).

'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).

'Application.SendKeys "^g ^g ^a {DEL} {F7}" 'Clears Immediate/Debug-output window.

Debug.Print Now

'Debug.Print Join(arr, ", ")

rngAllStns.EntireRow.Hidden = True

For Each cell In rngAllStns

If (IsInArray(cell.Value, arr)) Then

cell.EntireRow.Hidden = False

totArrElems = totArrElems + 1

End If

Next cell

MsgBox "Total count of visible rows: " & totArrElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count

End Sub

Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-4 Requires: searches for value set for variable 'FirstNameInRange' (such as"Avon") in column B, if not found exits gracefully, if found, auto-selects next 37 cells, then asks user to continue to hide rows, (search limited to 500 rows), uses Goto() instead of Cells(). Hides only unwanted rows (instead of hiding all rows first then unhide required). File: "CIPFA Stats 2014-15.xlsm".

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub HideOtherGroups()

Dim rngAllStns, cell As Range

Dim FirstNameInRange As String: FirstNameInRange = "Avon"

Dim ContiExec, visibleElems As Integer: visibleElems = 0

Dim arr As Variant

'Set rngAllStns = Range("b6:b43") 'reading source-data from sheet/range (instead of VBA code/array)

'Cells(1, 2).Select 'OR ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()

Application.Goto ActiveSheet.Range("B1"), True

'MsgBox ActiveCell.Address

Do While ActiveCell.Row < 500

ActiveCell.Offset(1, 0).Select

If (ActiveCell.Value = FirstNameInRange) Then

Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(46, 0)) 'total-1: Offset doesn't count current cell.

Exit Do

End If

Loop

'If Not rngAllStns Is Nothing Then 'range not defined remains EMPTY (not null), hence check with isEmpty().

If Not IsEmpty(rngAllStns) Then

rngAllStns.Select

Else

MsgBox """" & FirstNameInRange & """" & " not found."

Application.Goto ActiveSheet.Range("B1"), True

Exit Sub

End If

ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & " - Continue hiding row?", vbYesNo + vbQuestion)

If ContiExec = vbNo Then 'incorrect selection of cells - exit sub

Exit Sub

End If

'Manually storing stations in array - not reading from range on sheet:

arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",")

'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1

'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).

'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).

'Application.SendKeys "^g ^g ^a {DEL} {F7}" 'Clears Immediate/Debug-output window.

Debug.Print Now

'Debug.Print Join(arr, ", ")

'rngAllStns.EntireRow.Hidden = True 'hiding all rows in the range.

For Each cell In rngAllStns

If (IsInArray(cell.Value, arr)) Then

'cell.EntireRow.Hidden = False

visibleElems = visibleElems + 1

Debug.Print visibleElems & ". " & cell.Value

Else

'.EntireRow.Delete 'when deleting rows from a range, run loop-steps from bottom to top, otherwise error: "row/object doesn't exist".

cell.EntireRow.Hidden = True

End If

Next cell

MsgBox "Total count of visible rows: " & visibleElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count

End Sub

Searching & deleting rows not containing certain values (stored in an Array):

Requires: searches for value set for variable 'FirstNameInRange' (such as"Avon") in column B, if not found exits gracefully, if found, auto-selects next 37 cells, then asks user to continue to delete rows (search limited to 500 rows), uses Goto() instead of Cells(). Deletes rows from bottom (row-by-row). File: "CIPFA Stats 2014-15.xlsm".

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

Sub DeleteRowsFromOtherGroups()

'Search & hide all rows except matching values from a set of values (stored in an Array):

'Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows., file: "CIPFA Stats 2014-15.xlsm".

Dim rngAllStns As Range

Dim Firstrow, Lastrow As Long

Dim FirstNameInRange As String: FirstNameInRange = "England"

Dim ContiExec, visibleElems As Integer: visibleElems = 0

Dim arr As Variant

'Set rngAllStns = Range("b6:b43") 'reading source-data from sheet/range (instead of VBA code/array)

'Cells(1, 2).Select 'OR ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()

Application.Goto ActiveSheet.Range("B19"), True

'MsgBox ActiveCell.Address

Do While ActiveCell.Row < 500

ActiveCell.Offset(1, 0).Select

If (ActiveCell.Value = FirstNameInRange) Then

Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(46, 0)) 'total-1: Offset doesn't count current cell.

Exit Do

End If

Loop

'If Not rngAllStns Is Nothing Then 'range not defined remains EMPTY (not null), hence check with isEmpty().

If Not IsEmpty(rngAllStns) Then

rngAllStns.Select

Firstrow = rngAllStns.Cells(1).Row

Lastrow = rngAllStns.Rows(rngAllStns.Rows.Count).Row

'MsgBox Firstrow & " - " & Lastrow

Else

MsgBox """" & FirstNameInRange & """" & " not found."

Exit Sub

End If

ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & " - Continue hiding row?", vbYesNo + vbQuestion)

If ContiExec = vbNo Then 'incorrect selection of cells - exit sub

Exit Sub

End If

arr = Split("Bedfordshire & Luton,Royal Berkshire,Buckinghamshire,Cambridgeshire,Dorset,County Durham & Darlington,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",") 'manual array - without using range.

'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1

'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).

'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).

'Application.SendKeys "^g ^g ^a {DEL} {F7}" 'Clears Immediate/Debug-output window.

Debug.Print Now

'Debug.Print Join(arr, ", ")

'rngAllStns.EntireRow.Hidden = True

'For Each cell In rngAllStns

For Lrow = Lastrow To Firstrow Step -1

With Cells(Lrow, "B")

If (IsInArray(.Value, arr)) Then

'cell.EntireRow.Hidden = False

visibleElems = visibleElems + 1

Debug.Print visibleElems & ". " & .Value

Else

.EntireRow.Delete 'when deleting rows from a range, run loop-steps from bottom to top, otherwise error: "row/object doesn't exist".

'.EntireRow.Hidden = True

End If

End With

Next Lrow

MsgBox "Total count of visible rows: " & visibleElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count

End Sub

Simple Cut-Copy-Paste using VBA:

Following 1 liner copies a Range within same Sheet (to a specified destination):

Range("A1:D4").Copy(Range("E5"))

Following 1 liner copies a Range from Sheet1 to Sheet2 (at specified destination):

Worksheets("Sheet1").Range("A1:D4").Copy destination:=Worksheets("Sheet2").Range("E5")

Following code is generated by Macro recording that copies 1st row from Sheet1 to Sheet2:

Sub CopyRow() Worksheets("Sheet1").Rows(1).Copy Worksheets("Sheet2").Select Worksheets("Sheet2").Rows(1).Select Worksheets("Sheet2").PasteEnd Sub

Following code is hand written to skip blanks (Skip-Blanks including empty strings ""). Following checks for empty strings then copies a range:

Sub LoopingRows() Dim NewRow, LastRow As Long, r As Long: NewRow = 1 Sheets("Sheet3").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To LastRow 'If Cells(r, 1) > 0 Then Debug.Print Len(Cells(r, 1)) If Len(Cells(r, 1)) > 0 Then Range("A" & r & ":B" & r).Copy Range("D" & NewRow) NewRow = NewRow + 1 End If' If r > 500 Then' Exit For' End If Next rEnd Sub

'Following code asks confirmation, if user clicks Yes, Cuts the current row, and Pastes the row into specified sheet (here: "Completed Inc.").

Sub MoveRowFromIncompleteToCompleteSheet()

sh = ActiveSheet.Name

r = ActiveCell.Row

ans = MsgBox("Would you like to move current row to the ""Completed Inc."" sheet?", vbYesNo, "Move Row!")

If ans = vbYes Then

ActiveCell.EntireRow.Cut _

Destination:=Sheets("Completed Inc.").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

MsgBox "Row number: " & r & " has been moved to ""Completed Inc."" sheet"

Sheets(sh).Rows(r).EntireRow.Delete

End If

End Sub

Tirnary Operator in VBA

There is no ternary operator ( x = <condition> ? 1 : 2 ) in VBA, however if you really would like to write ternary operator you can use the IIF() ternary consional function in VBA. E.g.:

IIf(expr, truepart, falsepart)
function,

x =
IIf(<condition>, 1, 2)

, which reduces the verbosity of code.

----------------------------------------------------------------------------------------------

Word VBA Samples:

VBA Code 1: Remove all hyperlinks of current document

Sub RemoveHyperlinks()

      With ThisDocument

             'Loop while there are hyperlinks on document

             While .Hyperlinks.Count > 0

                   .Hyperlinks(1).Delete

             Wend

      End With

      'Turn off auto-hyperlinking:

      Application.Options.AutoFormatAsYouTypeReplaceHyperlinks = False

End Sub

VAB code 2: Remove all hyperlinks in all open documents

Sub RemoveHyperlinksInAllOpenDocuments()

      ' Removes all hyperlinks from any open documents

      Dim doc As Document

      Dim szOpenDocName As String

      'Loop through all open documents:

      For Each doc In Application.Documents

             'Store the document name

             szOpenDocName = doc.Name

             'Remove the hyperlinks from that document

             With Documents(szOpenDocName)

                   'Loop while there are hyperlinks afoot!

                   While .Hyperlinks.Count > 0

                                .Hyperlinks(1).Delete

                   Wend

             End With

             'Turn off auto-hyperlinking:

             Application.Options.AutoFormatAsYouTypeReplaceHyperlinks = False

      Next doc

End Sub

File Handling (Word-VBA)

Private Sub WriteToFile_Click()

'Open file in file-system: (creates new file if doesn't exist)

Open "C:\Temp\HoldPastes.txt" For Append As #1

'Read Clipboard content:

Dim myData As DataObject

Dim strClip As String

Set myData = New DataObject

myData.GetFromClipboard

strClip = myData.GetText

'Paste Clipboard content in the same file:

Selection.EndKey Unit:=wdStory, Extend:=wdMove

Selection.PasteSpecial DataType:=wdPasteText

'Write to file:

Write #1, "------------------------" & vbCrLf & vbCrLf & vbCrLf

Write #1, strClip

'Close file:

Close #1

End Sub

Private Sub ReadWriteFile_Click()

Dim sFirst, sLast, sAddress, sCity, sState, sZip As String

' CREATE DATA FILE

' Open file in current directory:

Open "Datafile.txt" For Output As #1

' Write data to file.

Write #1, "John", "Doe", "An Address", "A City", "A State", "A Zip"

' Close File.

Close #1

' RETRIEVE DATA FROM FILE

' Open file for input.

Open "Datafile.txt" For Input As #1

' Loop until the end of file is reached.

Do While Not EOF(1)

' Read data into variables.

Input #1, sFirst, sLast, sAddress, sCity, sState, sZip

' Print data to Debug window.

Debug.Print sFirst, sLast, sAddress, sCity, sState, sZip

Loop

' Close file.

Close #1

End Sub

Replacing Dodgy Characters
Converts Text-Paragraphs Into Html-Lists

Sub ConvertIntoHtmlParas()

'This macro first deletes all blank lines then encloses all the paragraphs in a document with (except paragraphs enclosed within <li></li>),

'Secondly this also replaces all special (dodgy) characters with plain characters.

Dim pCount As Integer

Dim paraCount As Integer

pCount = ActiveDocument.Paragraphs.Count

Selection.HomeKey Unit:=wdStory

For x = 1 To (pCount + 1)

Selection.MoveEnd Unit:=wdParagraph, Count:=1

If Len(Trim(Replace(Selection.Text, vbCr, ""))) < 1 Then ' Note: in MS-Word a new-line character is vbCr (NOT vbCrLf).

Selection.Delete

End If

Selection.EndOf (wdParagraph)

Selection.EndKey Unit:=wdStory

Selection.TypeText (vbCrLf)

Selection.HomeKey Unit:=wdStory

paraCount = ActiveDocument.Paragraphs.Count

For x = 2 To paraCount 'Starting from 2 (instead of 1) to skip last blank paragraph that was manually entered for consistency.

Selection.StartOf (wdParagraph)

Selection.MoveEnd Unit:=wdParagraph, Count:=1

If (InStr(1, Trim(Selection.Text), "<li>", vbTextCompare) = 0) Then

Selection.StartOf (wdParagraph)

Selection.TypeText ("")

Selection.EndOf (wdParagraph)

Selection.MoveLeft Unit:=wdCharacter, Count:=1

Selection.TypeText ("")

Selection.MoveDown Unit:=wdLine, Count:=1

Else

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove

End If

'Following section replaces dodgy characters: (¦`’‘“”– " ")

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "¦"

.Replacement.Text = "|"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

.Text = "‘" ' tr.Text.Replace(ChrW(8216), Chr(39))

.Replacement.Text = "'"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

.Text = "’" ' tr.Text.Replace(ChrW(8217), Chr(39))

.Replacement.Text = "'"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

.Text = ChrW(8220)

.Replacement.Text = """"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

.Text = ChrW(8221)

.Replacement.Text = """"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

.Text = "–"

.Replacement.Text = "-"

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

End With

End Sub

'Following Word-VBA Sub Converts Text-Paragraphs Into Html-Lists

Sub convertIntoHtmlLists()

'This macro encloses selected paragraphs within <li></li>, deleting all blank lines.

Dim pCount As Integer

pCount = ActiveDocument.Paragraphs.count

Selection.EndKey Unit:=wdStory

Selection.TypeText (vbCrLf)

Selection.HomeKey Unit:=wdStory

For x = 1 To pCount

Selection.MoveEnd Unit:=wdParagraph, count:=1

If Len(Trim(Selection.Text)) <= 1 Then

'If (str = vbCr Or str = vbCr Or str = vbCrLf) Then MsgBox "It is CRLF" End If

Selection.Delete

Else

Selection.StartOf (wdParagraph)

Selection.TypeText ("<li>")

Selection.EndOf (wdParagraph)

Selection.MoveLeft Unit:=wdCharacter, count:=1

Selection.TypeText ("</li>")

Selection.MoveRight Unit:=wdCharacter, count:=1

End If

End Sub

Sub convertIntoHtmlParas_OLD()

'This macro encloses all the paragraphs in a document with (In new separate lines), deleting all blank lines,

'it excludes paragraphs enclosed within <li></li> see next script.

Dim pCount As Integer

pCount = ActiveDocument.Paragraphs.count

Selection.EndKey unit:=wdStory

Selection.TypeText (vbCrLf)

Selection.HomeKey unit:=wdStory

For x = 1 To pCount

Selection.MoveEnd unit:=wdParagraph, count:=1

If Len(Trim(Selection.Text)) <= 1 Then

Selection.Delete

ElseIf (InStr(1, Trim(Selection.Text), "<li>", vbTextCompare) <= 0) Then

Selection.StartOf (wdParagraph)

Selection.TypeText ("")

Selection.TypeText (vbCrLf)

Selection.MoveDown unit:=wdLine, count:=1

Selection.EndOf (wdParagraph)

Selection.TypeText ("")

Selection.TypeText (vbCrLf)

Else

Selection.MoveRight unit:=wdCharacter, count:=1, Extend:=wdMove

End If

End Sub

ProperCase by macro

Sub Caps1stChar()

'This will convert the case of the first letter of selection into uppercase.

Dim txt As String

txt = ""

For i = 1 To Selection.Words.Count

txt = txt & StrConv(Selection.Words(i), vbProperCase)

Next i

Selection.Text = txt

End Sub

ProperCase with 1st character bold (Ver-1):

e.g. Propercase With 1st Character Bold:

'Ver1: Doesn't excludes anything, applies to all text including: punctuations, numbers and words such as 'of' & 'for'.

Sub BoldCaps1stChar()

Dim cnt As Integer

cnt = Selection.Words.Count

'move (without wdExtend) cursor to the left/beginning of the selection:

Selection.MoveLeft Unit:=wdCharacter, Count:=1

'running a loop to select the 1st character then highlight it:

For i = 1 To cnt

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

Selection.Font.Bold = wdToggle

Selection.Range.Case = wdUpperCase

Selection.MoveRight Unit:=wdWord, Count:=1

Next i

End Sub

ProperCase with 1st character bold (Ver-2):

'Ver2: Excludes all non-alphabets

Sub BoldCaps1stAlphas()

Dim cnt As Integer: cnt = Selection.Words.Count

Dim regEx As New RegExp

'requires: VBA reference to "Microsoft VBScript Regular Expressions 5.5" (under: VBE -> Tools -> References)

regEx.Pattern = "[a-zA-Z]"

'move (without wdExtend) cursor to the left/beginning of the selection:

Selection.MoveLeft Unit:=wdCharacter, Count:=1

'running a loop to select the 1st character then highlight it:

For i = 1 To cnt

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'MsgBox Left(Selection, 1)

'If (Selection = "," Or Selection = Chr(34) Or Selection = (Chr(34) & ",")) Then GoTo EndLoop End If

If regEx.Test(Left(Selection, 1)) Then

Selection.Font.Bold = wdToggle

Selection.Range.Case = wdUpperCase

End If

Selection.MoveRight Unit:=wdWord, Count:=1

'EndLoop:

Next i

End Sub

ProperCase with 1st character bold (Ver-3):

'Ver3: (EdChoice) Excludes all non-alphabets & certain words such as 'and', 'of' & 'for'.

Sub BoldCaps1stAlphas()

Dim cnt As Integer: cnt = Selection.Words.Count

Dim regEx As New RegExp

regEx.Pattern = "[a-zA-Z]"

'move (without wdExtend) cursor to the left/beginning of the selection:

Selection.MoveLeft Unit:=wdCharacter, Count:=1

'running a loop to select the 1st character then highlight it:

'For Each w In Selection.Words 'this won't work here as we need to alter the Words in selection.

For i = 1 To cnt

Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'select single word

'MsgBox (Selection) 'check which word

'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))

'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.

If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0) Then

Selection.MoveRight Unit:=wdWord, Count:=1

GoTo NextIteration

End If

Selection.MoveLeft Unit:=wdWord, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'check if selected character is an alphabet:

If (regEx.Test(Selection)) Then

Selection.Font.Bold = wdToggle

Selection.Range.Case = wdUpperCase

End If

Selection.MoveRight Unit:=wdWord, Count:=1

NextIteration:

Next i

End Sub

ProperCase with 1st character bold (Ver-4):

'Ver4: (EdChoice) Excludes all non-alphabets & certain words (stored in Array elements - makes long if statement redundant.

Sub Highlight1stCharacter()

Dim cnt As Integer: cnt = Selection.Words.Count

Dim regEx As New RegExp

regEx.Pattern = "[a-zA-Z]" 'requires: VBE>Tools>Reference: "Microsoft VBScript Regular Expressions 5.5".

Dim excl() As String

excl() = Split("and, of, for, to, with, in, on, a, an, the", ", ") 'One-liner array assignment.

'move (without wdExtend) cursor to the left/beginning of the selection:

Selection.MoveLeft Unit:=wdCharacter, Count:=1

'running a loop to select the 1st character then highlight it:

'For Each w In Selection.Words 'this won't work here as we need to alter the Words in selection.

For i = 1 To cnt

Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'select single word

'MsgBox (Selection) 'check which word

'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))

'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.

For Each x In excl

If (InStr(Selection, x & " ") > 0) Then

Selection.MoveRight Unit:=wdWord, Count:=1

GoTo NextIteration

End If

Next x

'above array-iteration replaces need of following Loooooong if statement:

'If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0 Or InStr(Selection, "to ") > 0) Then

Selection.MoveLeft Unit:=wdWord, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'check if selected character is an alphabet:

If (regEx.Test(Selection)) Then

Selection.Font.Bold = wdToggle

Selection.Range.Case = wdUpperCase

End If

Selection.MoveRight Unit:=wdWord, Count:=1

NextIteration:

Next i

End Sub

------------ x -------------

List of my IT blogs:

List of my other blogs:

Steps to heal tennis elbow