VBA Word - Little Tips

Sub CLOSE_ALL_WINDOWS()

'_______________________________________________
'

'This macro for Word closes all windows WITHOUT saving
'_______________________________________________
'

On Error GoTo MyHand

While (Documents.COUNT >= 1) = True
    ActiveWindow.Close SaveChanges:=wdDoNotSaveChanges
Wend


MyHand:
    If Err = 4248 Then
        Exit Sub
    End If

End Sub


Sub paginate()


'_______________________________________________
'

'This macro for Word inserts simple pagination for each page, top and center
'_______________________________________________
'

    With Selection.Sections(1).Headers(1).PageNumbers
        .NumberStyle = wdPageNumberStyleArabic
        .HeadingLevelForChapter = 0
        .IncludeChapterNumber = False
        .ChapterPageSeparator = wdSeparatorHyphen
        .RestartNumberingAtSection = False
        .StartingNumber = 0
    End With
    Selection.Sections(1).Headers(1).PageNumbers.Add PageNumberAlignment:= _
        wdAlignPageNumberCenter, FirstPage:=True
End Sub


Sub Tabs_Clear()


'_______________________________________________
'

'This macro for Word clears all tabs in all the document
'_______________________________________________
'

Selection.WholeStory
Selection.ParagraphFormat.TabStops.ClearAll

End Sub


Sub Language_ENG()

'_______________________________________________
'

'This macro for Word sets the language of the whole document to English UK
'_______________________________________________
'

    Selection.WholeStory
    Selection.LanguageID = wdEnglishUK
    Selection.HomeKey Unit:=wdStory
End Sub

Sub Language_SPA()

'_______________________________________________
'

'This macro for Word sets the language of the whole document to Modern Spanish
'_______________________________________________
'

    Selection.WholeStory
    Selection.LanguageID = wdSpanishModernSort
    Selection.HomeKey Unit:=wdStory
End Sub

Sub Language_FRE()
'_______________________________________________
'

'This macro for Word sets the language of the whole document to French France
'_______________________________________________
'
    Selection.WholeStory
    Selection.LanguageID = wdFrench
    Selection.HomeKey Unit:=wdStory
End Sub


Sub Add_Blank_Document()

'_______________________________________________
'

'This macro for Word adds a blank document
'_______________________________________________
'


If Documents.Count < 1 Then
   Documents.Add
End If
End Sub


Sub CombineFiles()

'_______________________________________________
'

' This macro for Word works with text files. It inserts
' one line of file 1, then one line of file 2, into a third file
'_______________________________________________
'


Dim i As Integer

Open "C:\First_File.txt" For Input As #1
Open "C:\Second_File.txt" For Input As #2
Open "C:\Result.txt" For Output As #3

'loop through first file
Do While Not EOF(1)
Do While Not EOF(2)

Line Input #1, MyString1

Print #3, MyString1

'loop through second file
Line Input #2, MyString2

Print #3, MyString2
Loop
Loop

MsgBox "Done"

Close #3
Close #2
Close #1

End Sub




Sub CopyFile()
'_______________________________________________
'

' This macro for Word copies a file.
'_______________________________________________
'   
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CopyFile "C:\File-1.txt", "C:\Copy-of-File-1.txt", True
    Set fso = Nothing
   
End Sub

VBA String Manipulations - Parsing Strings - 2

Parsing a String in a Cell based on its color,

change it and write back the result

   I assume here that the colored text is found at the middle or end of the string (for example:
   "This string has some color"). For other color combinations in the cells,
   like color at start, changes of color, this requires a much more complicated macro.

Sub Change_Part_of_String_in_Cell_Based_on_Its_Color()
' ______________________________________
'
' This VBA macro works in Excel
' ______________________________________
'
Dim myString, String_to_Parse, Front_String, Back_String As String
Dim myStartRow, myEndRow, myColData, myColResult As Long

myEndRow = 8            'Define on which row to end
myColData = 7           'Define the column number where is the data
myColResult = 11        'Define the column where to put the result

For myStartRow = 2 To myEndRow     'Define the Start Row and the End Row
 cells(myStartRow, myColData).Select
 myString = selection

 For i = 1 To ActiveCell.Characters.count
 'Loop through the characters inside the cell to find if
 'there is a font with some color.

  If (ActiveCell.Characters(i, 1).Font.Color <> vbAutomatic) Then

   'If there is some color, this color will
   'be found at the position of i in the loop.
   'Then extract the piece of string that has the color
   'and do what you want with it.

   'Here I'm giving this piece of colored text some HTML code, and then
   'I piece together the front of the string and the back of the string
   'with the new stuff and then writing the result in some other cell
  
    String_to_Parse = myString
    Front_String = Mid(myString, 1, i - 1)
    Back_String = Mid(myString, i)
   cells(myStartRow, myColResult).Value = Front_String & "<font color=""#800000""><b> " & _
    Back_String & "</b></font>"
  
   Exit For
   Else

    cells(myStartRow, myColResult).Value = cells(myStartRow, myColData).Value

    'If there is no colored font in the cell, do nothing to the string but
    'simply copy the cell value to the cell results

  End If
 
 Next i

Next myStartRow

End Sub

VBA Proofing - Add AutoCorrect Entry

Sub Automatically_Add_AutoCorrect_Entry()

'______________________________________
'
' This VBA macro adds an AutoCorrect Entry
' For example, "vba macro" becomes "VBA macro"
' This quick macro works in Word
'______________________________________
'
    AutoCorrect.Entries.Add Name:="vba macro", Value:="VBA macro"
 
    With AutoCorrect
        .ReplaceText = True
    End With
 
End Sub

VBA List all directories - Word

Sub List_All_Directories()

'______________________________________
'
'This VBA macro lists all directories, for example C:\
'This quick macro works in Word
'______________________________________
'

MyPath = "C:\"
MyName = Dir(MyPath, vbDirectory)

Do While MyName <> ""

    If MyName <> "." And MyName <> ".." Then

        If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
         
            With Selection
            WholeName = UCase(MyPath + MyName)
            .TypeText Text: = WholeName
               'if you also want the date and time, add this:
               ' & vbTab & FileDateTime(WholeName) & vbNewLine
            .InsertParagraphAfter
            .Collapse direction:=wdCollapseEnd
            Counter = Counter + 1
            End With

        End If

    End If
 
    MyName = Dir

Loop

End Sub

VBA Word Tables - Delete Rows if Duplicate Values

Sub Delete_Rows_If_Duplicate_Values_In_Column_Of_Table()
' _____________________________________________________________
'
' This macro deletes rows in a table in a Word document
' if sequential values in a column are duplicates
' _____________________________________________________________
'
' NOTE: if comparing alphabetical values, remember that "A" is not equal to "a"
' _____________________________________________________________
'
' FIRSTLY, you need to sort your table so that duplicate values in the column you
' are interested in are below one another; then run the macro
' _____________________________________________________________
'
' This VBA macros works in Word
' _____________________________________________________________
'
Dim i, Next_Cell As Integer, The_Cell_to_Check, The_Table_to_Check As Integer

The_Table_to_Check = 1
     ' Put 1 if it's the first table, 2 if it's the second table and so on...
                         
The_Cell_to_Check = 1
     ' Put the value of the column you are checking here
                         
ActiveDocument.Tables(The_Table_to_Check).Rows(1).Cells(The_Cell_to_Check).Select

    If Selection.Information(wdWithInTable) = True Then
        Number_of_Rows = Selection.Information(wdMaximumNumberOfRows)
       Next_Cell = Val(Number_of_Rows)
    End If

 For i = 1 To Next_Cell

    If i = Next_Cell Then Exit For
 
     ActiveDocument.Tables(The_Table_to_Check).Rows(i).Cells _
     (The_Cell_to_Check).Select
     
      First_Val = Trim(Mid(Selection.Text, 1, Len(Selection.Text) - 1))
   
     ActiveDocument.Tables(The_Table_to_Check).Rows(i + 1).Cells _
     (The_Cell_to_Check).Select
     
      Second_Val = Trim(Mid(Selection.Text, 1, Len(Selection.Text) - 1))

    If First_Val = Second_Val Then
     
     Selection.SelectRow
     Selection.Rows.Delete
     i = i - 1
     Selection.MoveUp Unit:=wdLine, COUNT:=1
     Next_Cell = Next_Cell - 1
 
    End If

 Next i

End Sub

VBA String Manipulations - Remove HTML tags

Sub RemoveTags()
' ______________________________________
'
' This macro removes tags such as < and >
' from a web page source code
' It works in Word
' ______________________________________
'

Dim MyRange As Range
Dim pos As Long

Set MyRange = ActiveDocument.Range
 With MyRange.Find
  Do While .Execute(findText:="(\<*\>)", _
   MatchWildcards:=True, _
   Wrap:=wdFindStop, Forward:=True) = True
   MyRange.Delete
  Loop
 End With

Set MyRange = Nothing

MsgBox "end macro"

End Sub


'______________________________________

'Another way to do the same job of removing html tags from the source code of a web page is:

'______________________________________

Sub Remove_All_Tags()
'______________________________________
'
' This VBA macro removes all tags from
' the source code of a web page
' For example, "<b>This text</b>"
' becomes "This text"
' This quick macro works in Word
'______________________________________
'
ActiveDocument.Select
If Selection.Find.Execute("<", 0, 0) Or Selection.Find.Execute("</", 0, 0) = True Then

Do

Selection.Extend (">")
Selection.Delete

ActiveDocument.Select

Loop Until Selection.Find.Execute("<", 0, 0) = False

Else
MsgBox "No < > tag was found"
End If

End Sub

VBA String Manipulations - Extract Numbers

Sub Extract_Numbers_Inside_A_String()
' ______________________________________
'
' This macro extracts figures from a string
' and writes them to cell A1
' It works in Excel
' ______________________________________
'
Dim Counter As Integer
Dim myString As String
Dim myValue As Variant

myString = "AFEAJFEOAnuioeujaénvniue58123" 'define string

For Counter = 1 To Len(myString)
    If IsNumeric(Mid(myString, Counter, 1)) Then
     myValue = Mid(myString, Counter, 1)
     cells(1, 1).Value = cells(1, 1).Value & myValue
    End If
Next

End Sub