Embedded Files
One common activity in Excel is to compare two columns. It's possible to compare values using mathematical operations, but comparing text is not possible.
Someone on Stack Overflow came up with the brilliant method of using Word to do textual comparison. This means you can clearly show additions and removals using the traditional redlines and strikethroughs. The original macro would only compare one cell with another.
Below is a macro based on this with some enhancements, which prompts the user about which cells contain the original text, the new text, and where to place the diffs.
Some Limitations
Some Limitations
Save you work before you run this macro!!
Excel does not like carriage returns - so this macro converts all carriage returns and line feeds into Þ characters. It would be good to convert these Þ back into carriage returns. However Excel mucks up character formatting when doing this conversion when using the default find/replace operation. And any changes to .value or .formula will nix all the character formatting in the cell. You then have to reapply character formatting using .character.
It is extremely slow to update character formatting where the cell length is greater than 255 (since .character is a very time-expensive operation). So I've added another macro in there that detects runs of characters and sets these formats in one go, which reduces the time taken (with a little help from ChatGPT). If you want to replace Þ with LF manually, there is a macro at the bottom called "Replace_With_Carriage_Return_interactive".
There may be another method to use XML to do the find-replace, but I haven't looked into this any further, and I think it means Excel needs to close the file to manipulate the XML: https://stackoverflow.com/questions/61654127/faster-alternatives-to-characters-object
It'll only work with one column with all the cells unhidden. Don't even try doing more than one column. It will avoid hidden cells or filtered cells. Don't try multi-selections - it'll probably go whacky and put things in random columns.
To speed things up a little, the CompareMultipleCellsSlow() will only call Word Compare when really needed, by skipping blank cells and detecting cells with no changes.
This macro compares multiple selected cells. The trick is to put everything into tables before doing the comparison using Word.
This requires that your Excel VBA project has a reference to the Word object library and RegEx library. You can add these from within the VBA editor by clicking Tools > References, and selecting Microsoft Word XX.Y Object Library, where XX.Y is whatever version you have installed.
#If VBA7 Then
'For 64-Bit MS Office
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
#Else
'For 32-Bit MS Office
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
#End If
Public Sub CompareMultipleCells()
' ####################
' Basic Flow
'
' 1. Get the text content of the two cells to compare.
' 2. Get an open instance of MS Word, or spin up a new one.
' 3. Use Word's text-comparison features to generate the tracked-changes markup.
' 4. Copy that markup to the clipboard.
' 5. Then just paste that into our target cell.
'
' This requires that your Excel VBA project has a reference to the
' Word object library. You can add this from within the VBA editor
' by clicking Tools > References, and selecting Microsoft Word XX.Y
' Object Library, where XX.Y is whatever version you have installed.
' Also this requires Microsoft VBScript Regular Expressions 5.5.
'
' Original version from here:
' https://stackoverflow.com/questions/30541753/improve-redline-comparison-of-cells
'
' Updated by Edward Chan to compare multiple cells
' ####################
Dim oldRng As Range
Dim NewRng As Range
Dim cmpRng As Range
Dim StrSrc As String
Dim StrTgt As String
Dim ThisSheet As Excel.Worksheet: Set ThisSheet = Excel.ActiveSheet
Dim oldtext As String
Dim newtext As String
Dim cell As Range
Dim fullCompare As Boolean
Call CloseWordFile_If_Open_And_Not_Visible ' If there was a previous run that was bad, close all those first
Application.Calculation = xlManual
' Set oldRng = ActiveSheet.range("A1:A4")
' Set newRng = ActiveSheet.range("B1:B4")
' Set cmpRng = ActiveSheet.range("C1:C4")
On Error GoTo quit
Set oldRng = Application.InputBox("Select the old text range:", "Compare Cells", Application.Selection.Address, Type:=8)
For i = 1 To 50
If oldRng.Offset(0, i).ColumnWidth <> 0 Then Exit For
Next
oldRng.Offset(0, i).Select
Set NewRng = Application.InputBox("Select the new text range:", "Compare Cells", oldRng.Offset(0, i).Address, Type:=8)
For i = 1 To 50
If NewRng.Offset(0, i).ColumnWidth <> 0 Then Exit For
Next
NewRng.Offset(0, i).Select
Set cmpRng = Application.InputBox("Select the range to put the results in:", "Compare Cells", NewRng.Offset(0, i).Address, Type:=8)
intanswer = MsgBox("Would you like to show real carriage returns in the compared column? (This is a little slower)", vbYesNo, "Please Confirm")
If intanswer = vbNo Then fullCompare = False Else fullCompare = True
If WorksheetFunction.CountA(Range(cmpRng.Address)) <> 0 Then
intanswer = MsgBox("The output range is not blank. Would you like to continue?", vbOKCancel, "Please Confirm")
If intanswer = vbCancel Then
Application.Calculation = xlAutomatic
Exit Sub
End If
End If
On Error GoTo 0
intanswer = MsgBox("This operation can take a long time and uses the clipboard. " & Chr(10) & Chr(10) & "To abort press one of the following: " & Chr(10) & Chr(10) & "ESC twice" & Chr(10) & "Alt + Esc" & Chr(10) & "Fn + Ctrl + B" & Chr(10) & "Fn + Break", vbOKOnly + vbInformation, "")
Dim Wd As Word.Application: Set Wd = GetApp("Word")
Dim DocOrig As Word.Document, DocChgd As Word.Document, DocMarkup As Word.Document
Set DocOrig = Wd.Documents.Add(Visible:=False)
Set DocChgd = Wd.Documents.Add(Visible:=False)
For c = 1 To oldRng.Cells.Count
If oldRng.Cells(c).RowHeight = 0 Then
' Do nothing, skip it!
ElseIf VarType(oldRng.Cells(c)) = vbError And VarType(NewRng.Cells(c)) = vbError Then ' There's an error, just don't compare
clearformats (cmpRng(c))
cmpRng(c).Value = "Error in cell, cannot compare"
cmpRng(c).Font.Color = -16776961
ElseIf VarType(oldRng.Cells(c)) = vbError Then ' There's an error in the old range, just use new range text as blue
clearformats (cmpRng(c))
cmpRng(c).Value = NewRng.Cells(c).Value
cmpRng(c).Font.Color = -65536
ElseIf VarType(NewRng.Cells(c)) = vbError Then ' There's an error in the new range, just use old range text as red strikethrough
clearformats (cmpRng(c))
cmpRng(c).Value = oldRng.Cells(c).Value
cmpRng(c).Font.Strikethrough = True
cmpRng(c).Font.Color = -16776961
ElseIf oldRng.Cells(c).text = "" And NewRng.Cells(c).text = "" Then ' both blank
' Do nothing, skip it!
clearformats (cmpRng(c))
cmpRng(c).ClearContents
ElseIf oldRng.Cells(c).text = "" Then ' Only new text so should be blue
clearformats (cmpRng(c))
cmpRng(c).Value = NewRng.Cells(c).Value
cmpRng(c).Font.Color = -65536
ElseIf NewRng.Cells(c).text = "" Then ' Only old text so should be red strikethrough
clearformats (cmpRng(c))
cmpRng(c).Value = oldRng.Cells(c).Value
cmpRng(c).Font.Strikethrough = True
cmpRng(c).Font.Color = -16776961
ElseIf oldRng.Cells(c).text = NewRng.Cells(c).text Then
' It's the same, don't do the expensive compare operation, just plonk the text straight in.
clearformats (cmpRng(c))
cmpRng(c).Value = NewRng.Cells(c).Value
ElseIf ReplaceWhitespaceCR(oldRng.Cells(c).text) = ReplaceWhitespaceCR(NewRng.Cells(c).text) Then
' It's pretty close to the same apart from whitespace and carriage returns, don't do the expensive compare operation, just plonk the text straight in.
clearformats (cmpRng(c))
cmpRng(c).Value = NewRng.Cells(c).Value
Else
' They are still different, time to do a Word Compare.
StrSrc = ReplaceWhitespace(oldRng.Cells(c).text)
StrSrc = Replace(StrSrc, Chr(10), Chr(222) & " ") ' Replace enter with Þ and space (to clean up word compares)
StrTgt = ReplaceWhitespace(NewRng.Cells(c).text)
StrTgt = Replace(StrTgt, Chr(10), Chr(222) & " ") ' Replace enter with Þ and space (to clean up word compares)
' Debug.Print StrSrc
' Debug.Print StrTgt
' Do the comparison in Microsoft Word
DocOrig.Content = StrSrc
DocChgd.Content = StrTgt
Set DocMarkup = Wd.CompareDocuments( _
OriginalDocument:=DocOrig, _
RevisedDocument:=DocChgd, _
Destination:=wdCompareDestinationNew, _
Granularity:=wdGranularityWordLevel, _
CompareFormatting:=False, _
CompareCaseChanges:=True, _
CompareWhitespace:=False, _
CompareTables:=True, _
CompareHeaders:=False, _
CompareFootnotes:=True, _
CompareTextboxes:=True, _
CompareFields:=False, _
CompareComments:=True, _
CompareMoves:=True, _
RevisedAuthor:="Changed to", _
IgnoreAllComparisonWarnings:=False _
)
' Set the Word Options to use Blue for inserts and Red for deletions
With Wd.Options
.InsertedTextMark = wdInsertedTextMarkColorOnly
.InsertedTextColor = wdBlue
.DeletedTextMark = wdDeletedTextMarkStrikeThrough
.DeletedTextColor = wdRed
.RevisedPropertiesMark = wdRevisedPropertiesMarkNone
.RevisedPropertiesColor = wdByAuthor
.RevisedLinesMark = wdRevisedLinesMarkNone
.CommentsColor = wdByAuthor
.RevisionsBalloonPrintOrientation = wdBalloonPrintOrientationPreserve
End With
Wd.ActiveWindow.View.RevisionsMode = wdInLineRevisions
With Wd.Options
.MoveFromTextMark = wdMoveFromTextMarkHidden
.MoveFromTextColor = wdAuto
.MoveToTextMark = wdMoveToTextMarkColorOnly
.MoveToTextColor = wdAuto
.InsertedCellColor = wdCellColorNoHighlight
.MergedCellColor = wdCellColorLightYellow
.DeletedCellColor = wdCellColorPink
.SplitCellColor = wdCellColorLightOrange
End With
With DocMarkup
.TrackMoves = True
.TrackFormatting = True
End With
DocMarkup.Content.Copy
cmpRng(c).Value = "" ' Clear the cell text
On Error Resume Next ' Don't bomb out if paste error, just check after the paste
pasteErrorCount = 0
Do While cmpRng(c).Value = "" Or pasteErrorCount = 100 ' Try pasting for 40 * 100 = 4 seconds
Sleep (40) ' Required to give time for the clipboard to populate
cmpRng(c).Select
ThisSheet.Paste
Loop
On Error GoTo 0 ' Turn on error checking again
If cmpRng(c).Value = "" Then
MsgBox "Cannot paste due to another system operation! Aborting operation, please try again from cell " & oldRng.Cells(c).Address
GoTo cleanup
End If
DocMarkup.Close SaveChanges:=False
If fullCompare = True Then
Call Replace_With_LF(cmpRng(c), cmpRng(c))
End If
Call copyBorders(NewRng.Cells(c), cmpRng(c))
End If
DoEvents
Next
cleanup:
cmpRng.Cells.HorizontalAlignment = xlGeneral
cmpRng.Cells.VerticalAlignment = xlTop
cmpRng.Cells.WrapText = True
' Cleanup
DocOrig.Close SaveChanges:=False
DocChgd.Close SaveChanges:=False
If Wd.Documents.Count = 0 Then Wd.quit
cmpRng.Select
quit:
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
DoEvents
DoEvents
Application.ScreenUpdating = True
Call CloseWordFile_If_Open_And_Not_Visible
Set Wd = Nothing
Application.ScreenUpdating = True
End Sub
Public Function GetApp(AppName As String) As Object
Dim app As Object
On Error GoTo Handler
Set app = GetObject(, AppName & ".Application")
Set GetApp = app
Exit Function
On Error GoTo 0
Handler:
If Err.Number > 0 And Err.Number <> 429 Then ' Unknown error, so error out
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Exit Function
End If
DoEvents
' If we get here, there's no open app by that name, so start a new instance.
Set app = CreateObject(AppName & ".Application")
Set GetApp = app
End Function
Sub Replace_With_LF_interactive()
' Edward Chan 2003
Dim OrigRng As Range
Dim NewRng As Range
On Error GoTo quit
Set OrigRng = Application.InputBox("Select the range to replace Þ:" & Chr(10) & "Note: This a very slow operation!!", "Replace Þ", Application.Selection.Address, Type:=8)
Application.Selection.Offset(0, 1).Select
Set NewRng = Application.InputBox("Select the range to put the output:", "Replace Þ", Application.Selection.Address, Type:=8)
On Error GoTo 0
If WorksheetFunction.CountA(NewRng.Address) <> 0 Then
intanswer = MsgBox("The output range is not blank. Would you like to continue?", vbOKCancel, "Please Confirm")
If intanswer = vbCancel Then Exit Sub
End If
Call Replace_With_LF(OrigRng, NewRng)
quit:
Application.Calculation = xlAutomatic
End Sub
Sub Replace_With_LF(OrigRng As Range, NewRng As Range)
' Edward Chan 2003
Dim rng As Range
Dim charIndex As Long
Dim formatArray() As Variant
Dim newValue As String
calcState = Application.Calculation
Application.Calculation = xlManual
c = 0
' Grab all the formatting in the cell as a separate array
For Each rng In OrigRng
c = c + 1
' This subroutine takes a long time because Excel is very slow when doing character.font operations.
' It's possible to copy out the text into Word and use this to get each character
' formatting instead. But doing that is also pretty slow, o well.
charIndex = InStr(1, rng.Value, "Þ")
If charIndex > 0 Then
Application.ScreenUpdating = False
newValue = Replace(rng.Value, "Þ", Chr(10))
ReDim formatArray(1 To Len(newValue) + Len(newValue) - Len(rng.Value), 1 To 16)
j = 0
For i = 1 To Len(newValue)
j = j + 1
formatArray(j, 1) = rng.Characters(i, 1).Font.Name
formatArray(j, 2) = rng.Characters(i, 1).Font.FontStyle
formatArray(j, 3) = rng.Characters(i, 1).Font.Size
formatArray(j, 4) = rng.Characters(i, 1).Font.Strikethrough
formatArray(j, 5) = rng.Characters(i, 1).Font.Superscript
formatArray(j, 6) = rng.Characters(i, 1).Font.Subscript
formatArray(j, 7) = rng.Characters(i, 1).Font.OutlineFont
formatArray(j, 8) = rng.Characters(i, 1).Font.Shadow
formatArray(j, 9) = rng.Characters(i, 1).Font.Underline
On Error Resume Next ' Some characters don't have ThemeColor, they just have Color.
formatArray(j, 10) = rng.Characters(i, 1).Font.ThemeColor
On Error GoTo 0
formatArray(j, 11) = rng.Characters(i, 1).Font.Color
formatArray(j, 12) = rng.Characters(i, 1).Font.TintAndShade
formatArray(j, 13) = rng.Characters(i, 1).Font.ThemeFont
formatArray(j, 14) = rng.Characters(i, 1).Font.Bold
formatArray(j, 15) = rng.Characters(i, 1).Font.Italic
formatArray(j, 16) = rng.Characters(i, 1).Font.ColorIndex
If rng.Characters(i - 1, 2).text = "Þ " Then ' It's a "Þ " so ignore the space. This assumes that a space is always added, which helps clean up the Word compares.
newValue = Left(newValue, j - 1) & Mid(newValue, j + 1) ' Remove the space from the text
j = j - 1 ' Go back one character
ElseIf rng.Characters(i, 1).text = "Þ" Then
formatArray(j, 1) = rng.Characters(i, 1).Font.Name
formatArray(j, 2) = rng.Characters(i, 1).Font.FontStyle
formatArray(j, 3) = rng.Characters(i, 1).Font.Size
formatArray(j, 4) = rng.Characters(i, 1).Font.Strikethrough
formatArray(j, 5) = rng.Characters(i, 1).Font.Superscript
formatArray(j, 6) = rng.Characters(i, 1).Font.Subscript
formatArray(j, 7) = rng.Characters(i, 1).Font.OutlineFont
formatArray(j, 8) = rng.Characters(i, 1).Font.Shadow
formatArray(j, 9) = rng.Characters(i, 1).Font.Underline
On Error Resume Next
formatArray(j, 10) = 0
formatArray(j, 10) = rng.Characters(i, 1).Font.ThemeColor
On Error GoTo 0
formatArray(j, 11) = rng.Characters(i, 1).Font.Color
formatArray(j, 12) = rng.Characters(i, 1).Font.TintAndShade
formatArray(j, 13) = rng.Characters(i, 1).Font.ThemeFont
formatArray(j, 14) = rng.Characters(i, 1).Font.Bold
formatArray(j, 15) = rng.Characters(i, 1).Font.Italic
formatArray(j, 16) = rng.Characters(i, 1).Font.ColorIndex
End If
Next i
NewRng(c).Value = newValue
Dim startIndex As Long
Dim endIndex As Long
startIndex = 1
endIndex = 1
For i = 2 To Len(newValue)
If Not (formatArray(i, 1) = formatArray(i - 1, 1) And _
formatArray(i, 2) = formatArray(i - 1, 2) And _
formatArray(i, 3) = formatArray(i - 1, 3) And _
formatArray(i, 4) = formatArray(i - 1, 4) And _
formatArray(i, 5) = formatArray(i - 1, 5) And _
formatArray(i, 6) = formatArray(i - 1, 6) And _
formatArray(i, 7) = formatArray(i - 1, 7) And _
formatArray(i, 8) = formatArray(i - 1, 8) And _
formatArray(i, 9) = formatArray(i - 1, 9) And _
formatArray(i, 10) = formatArray(i - 1, 10) And _
formatArray(i, 11) = formatArray(i - 1, 11) And _
formatArray(i, 12) = formatArray(i - 1, 12) And _
formatArray(i, 13) = formatArray(i - 1, 13) And _
formatArray(i, 14) = formatArray(i - 1, 14) And _
formatArray(i, 15) = formatArray(i - 1, 15) And _
formatArray(i, 16) = formatArray(i - 1, 16)) Then
endIndex = i - 1
With NewRng(c).Characters(startIndex, endIndex - startIndex + 1).Font
.Name = formatArray(startIndex, 1)
.FontStyle = formatArray(startIndex, 2)
.Size = formatArray(startIndex, 3)
.Strikethrough = formatArray(startIndex, 4)
.Superscript = formatArray(startIndex, 5)
.Subscript = formatArray(startIndex, 6)
.OutlineFont = formatArray(startIndex, 7)
.Shadow = formatArray(startIndex, 8)
.Underline = formatArray(startIndex, 9)
If Not formatArray(startIndex, 10) = 0 Then
.ThemeColor = formatArray(startIndex, 10) ' Some characters don't have ThemeColor
Else
.Color = formatArray(startIndex, 11)
End If
.TintAndShade = formatArray(startIndex, 12)
.ThemeFont = formatArray(startIndex, 13)
.Bold = formatArray(startIndex, 14)
.Italic = formatArray(startIndex, 15)
.ColorIndex = formatArray(startIndex, 16)
End With
startIndex = i
End If
Next i
' Apply formatting to the last run of characters
endIndex = Len(newValue)
With NewRng(c).Characters(startIndex, endIndex - startIndex + 1).Font
.Name = formatArray(startIndex, 1)
.FontStyle = formatArray(startIndex, 2)
.Size = formatArray(startIndex, 3)
.Strikethrough = formatArray(startIndex, 4)
.Superscript = formatArray(startIndex, 5)
.Subscript = formatArray(startIndex, 6)
.OutlineFont = formatArray(startIndex, 7)
.Shadow = formatArray(startIndex, 8)
.Underline = formatArray(startIndex, 9)
If Not formatArray(startIndex, 10) = 0 Then
.ThemeColor = formatArray(startIndex, 10) ' Some characters don't have ThemeColor
Else
.Color = formatArray(startIndex, 11)
End If
.TintAndShade = formatArray(startIndex, 12)
.ThemeFont = formatArray(startIndex, 13)
.Bold = formatArray(startIndex, 14)
.Italic = formatArray(startIndex, 15)
.ColorIndex = formatArray(startIndex, 16)
End With
NewRng(c).Select
Application.ScreenUpdating = True
DoEvents
DoEvents
ElseIf rng.Address <> NewRng(c).Address Then ' Copy cell to new location if a different cell
rng.Copy
NewRng(c).Select
NewRng(c).PasteSpecial (xlPasteAll)
End If
Next rng
NewRng.Select
quit:
Application.Calculation = calcState
End Sub
Sub ExtractRedCharactersFromMultipleCellsRGBNoCheck()
Dim cell As Range
Dim OrigRng As Range
On Error GoTo quit
Set OrigRng = Application.InputBox("Select the range to extract:", "", Application.Selection.Address, Type:=8)
If WorksheetFunction.CountA(Range(OrigRng.Offset(0, 1).Address)) <> 0 Then
intanswer = MsgBox("The output range is not blank. Would you like to continue?", vbOKCancel, "Please Confirm")
If intanswer = vbCancel Then Exit Sub
End If
On Error GoTo 0
For Each cell In OrigRng
Dim i As Long
Dim extractedText As String
extractedText = ""
For i = 1 To Len(cell.Value)
If cell.Characters(i, 1).Font.Color = RGB(255, 0, 0) Then
extractedText = extractedText & Mid(cell.Value, i, 1)
End If
Next i
cell.Offset(0, 1).Value = extractedText
cell.Offset(0, 1).Font.Color = RGB(255, 0, 0)
cell.Offset(0, 1).Font.Strikethrough = True
Next cell
quit:
Application.Calculation = xlAutomatic
End Sub
Sub ExtractBlueCharactersFromMultipleCellsRGBNoCheck()
Dim cell As Range
Dim OrigRng As Range
On Error GoTo quit
Set OrigRng = Application.InputBox("Select the range to extract:", "", Application.Selection.Address, Type:=8)
On Error GoTo 0
If WorksheetFunction.CountA(Range(OrigRng.Offset(0, 2).Address)) <> 0 Then
intanswer = MsgBox("The output range is not blank. Would you like to continue?", vbOKCancel, "Please Confirm")
If intanswer = vbCancel Then Exit Sub
End If
For Each cell In OrigRng
Dim i As Long
Dim extractedText As String
extractedText = ""
For i = 1 To Len(cell.Value)
If cell.Characters(i, 1).Font.Color = RGB(0, 0, 255) Then
extractedText = extractedText & Mid(cell.Value, i, 1)
End If
Next i
cell.Offset(0, 2).Value = extractedText
cell.Offset(0, 2).Font.Color = RGB(0, 0, 255)
Next cell
quit:
Application.Calculation = xlAutomatic
End Sub
Sub CloseWordFile_If_Open_And_Not_Visible()
Dim wdApp As Word.Application
Dim doc As Word.Document
On Error Resume Next ' This is required because sometimes Word takes time to close
Set wdApp = Nothing
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Exit Sub
End If
For Each doc In wdApp.Documents
If doc.Windows.Count <> 0 Then ' no docs left
If doc.Windows(1).Visible = False Then
doc.Close (wdDoNotSaveChanges)
End If
End If
Next doc
c = 0
If wdApp.Documents.Count = 0 Then ' No more documents
Do While c < 10
wdApp.quit (wdDoNotSaveChanges) ' Close Word, try for 10s
Application.Wait Now + #12:00:01 AM#
Set wdApp = Nothing
Set wdApp = GetObject(, "Word.Application")
If Not (wdApp Is Nothing) Then
c = c + 1
Else
Exit Do
End If
Loop
End If
On Error GoTo 0
Set wdApp = Nothing
End Sub
Function clearformats(rng As Range)
rng.Font.FontStyle = ""
rng.Font.Size = 10
rng.Font.Strikethrough = False
rng.Font.Superscript = False
rng.Font.Subscript = False
rng.Font.OutlineFont = False
rng.Font.Shadow = False
rng.Font.Underline = False
rng.Font.Color = RGB(0, 0, 0)
rng.Font.TintAndShade = 0
rng.Font.Bold = False
rng.Font.Italic = False
rng.Font.ColorIndex = xlColorIndexAutomatic
End Function
Sub copyBorders(rgFrom As Range, rgTo As Range)
rgTo.Borders.LineStyle = rgFrom.Borders.LineStyle
rgTo.Borders.Color = rgFrom.Borders.Color
rgTo.Borders.ColorIndex = rgFrom.Borders.ColorIndex
rgTo.Borders.TintAndShade = rgFrom.Borders.TintAndShade
rgTo.Borders.Weight = rgFrom.Borders.Weight
End Sub
Function ReplaceWhitespace(inputString)
Dim regex As New RegExp
' Set the regular expression pattern for whitespaces (spaces and tabs), non-breaking spaces
regex.Pattern = "[ \t\u00A0]+"
regex.Global = True
' Replace multiple spaces, and tabs with a single space
ReplaceWhitespace = regex.Replace(inputString, " ")
' Set the regular expression pattern for optional space before and after and carriage returns
regex.Pattern = " *[\r\n]+ *"
regex.Global = True
regex.IgnoreCase = True
' Replace carriage returns and any optional spaces with just a single carriage return
ReplaceWhitespace = regex.Replace(ReplaceWhitespace, Chr(10))
' Set the regular expression pattern for whitespaces (spaces and tabs), non-breaking spaces at the end of a line
regex.Pattern = "[ \t\u00A0]+$"
regex.Global = True
' Replace with nothing
ReplaceWhitespace = regex.Replace(ReplaceWhitespace, "")
' Replace with nothing
ReplaceWhitespace = regex.Replace(ReplaceWhitespace, "")
' Output the result
' Debug.Print ReplaceWhitespace
End Function
Function ReplaceWhitespaceCR(inputString)
Dim regex As New RegExp
' Set the regular expression pattern for whitespaces (spaces and tabs), non-breaking spaces
regex.Pattern = "[ \t\u00A0]+"
regex.Global = True
' Replace multiple spaces, and tabs with a single space
ReplaceWhitespaceCR = regex.Replace(inputString, " ")
' Set the regular expression pattern for optional space before and after and carriage returns
regex.Pattern = " *[\r\n]+ *"
regex.Global = True
regex.IgnoreCase = True
' Replace carriage returns and any optional spaces with a space
ReplaceWhitespaceCR = regex.Replace(ReplaceWhitespaceCR, " ")
' Set the regular expression pattern for whitespaces (spaces and tabs), non-breaking spaces at the start of a line
regex.Pattern = "^[ \t\u00A0]+"
regex.Global = True
' Replace with nothing
ReplaceWhitespaceCR = regex.Replace(ReplaceWhitespaceCR, "")
' Set the regular expression pattern for whitespaces (spaces and tabs), non-breaking spaces at the end of a line
regex.Pattern = "[ \t\u00A0]+$"
regex.Global = True
' Replace with nothing
ReplaceWhitespaceCR = regex.Replace(ReplaceWhitespaceCR, "")
' Set the regular expression pattern for spaces that don't make any reading differences
regex.Pattern = "([^\w\d])( )([^\w\d])"
regex.Global = True
' Replace with nothing
ReplaceWhitespaceCR = regex.Replace(ReplaceWhitespaceCR, "$1$3")
' Output the result of each character in ASCII
' For i = 1 To Len(ReplaceWhitespaceCR)
' Debug.Print Asc(Mid(ReplaceWhitespaceCR, i, 1)) & ",";
' Next
' Debug.Print
End Function
Page updated
Google Sites
Report abuse