TextDiff - Excel VBA Utility
TextDiff - Excel VBA Utility for character-by-character differences between two paragraphs/code snippets.
'******************************************************************************************
'Written by: Eddie Kumar Shrivastava
'Main method: Sub CompareAndHighlightDiffs() - this is the main/parent function that calls relevant dependencies/sub-routines.
'Description: Utility to quickly find character-by-character differences between two paragraphs/code snippets in Cells [A1] & [B1].
'Usage: In Excel spreadsheet copy-paste the two paragraphs/code snippets (that need to be compared) in Cells [A1] & [B1], then run the CompareAndHighlightDiffs() function.
'Date Created: 29-09-2017
'Date Modified: 23-10-2017
'Version: 1.2
'Version info/Change Log:
' - Added feature to span/merge multiple cells, when text overflows out of first cell.
' - Fixed issue with recognition of the repeating words.
'******************************************************************************************
'Following (CompareAndHighlightDiffs) is the main/parent function that calls relevant dependencies/sub-routines.
'TEXT COMPARISON: Following sub compares text and highlights the differences between cells A1 against B1:
Sub CompareAndHighlightDiffs()
Call BasicEqualityCheck([A1], [B1], False)
'TRIMMING WHITE-SPACE:
'Trimming Left & Right BLANKS:
[A1].Value = Trim([A1].Value)
[B1].Value = Trim([B1].Value)
'Trimming Left & Right NEWLINE-CHARS:
[A1].Value = TrimNewLineCharsFromEdges([A1].Value)
[B1].Value = TrimNewLineCharsFromEdges([B1].Value)
Call SortThenCopyA1B1ValuesToA3B3
Call CompareAndHighlightPassedValues([A1], [B1])
Call CompareAndHighlightPassedValues([A3], [B3])
Call FixRowHeightLimit
End Sub
Sub CompareAndHighlightPassedValues(CellA As Range, CellB As Range)
'------------------------
'CHAR-BY-CHAR Comparison:
'------------------------
Dim posA, posRevA As Integer
Dim posB, posRevB As Integer
'Dim s1, s2 As String
's1 = CellA
's2 = CellB
s1 = CellA.Value
s2 = CellB.Value
s1 = ReplaceWhiteSpaces(s1)
s2 = ReplaceWhiteSpaces(s2)
trimmedTxt1 = Replace(s1, "¬", "")
trimmedTxt2 = Replace(s2, "¬", "")
Call BasicEqualityCheck(trimmedTxt1, trimmedTxt2, True)
'Hightlighting entire text of both cells:
Call HighlightCellText(CellA)
Call HighlightCellText(CellB)
posA = GetFirstDiffNonWhitespaceCharPosition(s1, s2)
posB = GetFirstDiffNonWhitespaceCharPosition(s2, s1)
s1 = StrReverse(s1)
s2 = StrReverse(s2)
' Debug.Print s1
posRevA = GetFirstDiffNonWhitespaceCharPosition(s1, s2)
posRevB = GetFirstDiffNonWhitespaceCharPosition(s2, s1)
'CellA Formatting:
'With CellA.Characters(posA, Len(s1) - ((posRevA + posA) - 2)).Font 'character in the middle.
With CellA.Characters(1, posA - 1).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' If Len(s1) > (posA + posRevA) - 2 Then
With CellA.Characters(Len(s1) - (posRevA - 2), Len(s1)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' End If
'CellB Formatting:
'With CellB.Characters(posB, Len(s1) - ((posRevB + pos) - 2)).Font 'characters in the middle.
With CellB.Characters(1, posB - 1).Font
.ColorIndex = 0 'black Index
.fontStyle = "Regular"
End With
' If Len(s2) > (posB + posRevB) - 2 Then
With CellB.Characters(Len(s2) - (posRevB - 2), Len(s2)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' End If
'
'------------------------
'WORD-BY-WORD Comparison (for unmatched words):
'------------------------
' MsgBox Mid(CellA, pos, Len(s1) - ((posRevA + pos) - 2)) 'characters in the middle.
' MsgBox Mid(CellB, pos, Len(s2) - ((posRevA + pos) - 2)) 'characters in the middle.
'Starting positions of Unmatch-text:
Dim unmatPosA, unmatPosB As Integer
unmatPosA = posA 'Start comparing from posA - where first diff-char was found.
unmatPosB = posB
'Initialisation of the variable holding Unmatched-text:
Dim unmatchedA, unmatchedB As String 'unmatched characters in the middle.
If Len(s1) > ((posRevA + posA) - 2) Then
unmatchedA = WorksheetFunction.Trim(Mid(CellA, posA, Len(s1) - ((posRevA + posA) - 2)))
Else
unmatchedA = ""
End If
If Len(s2) > ((posRevB + posB) - 2) Then
unmatchedB = WorksheetFunction.Trim(Mid(CellB, posB, Len(s2) - ((posRevB + posB) - 2)))
Else
unmatchedB = ""
End If
Dim cIndex As Integer: cIndex = 0
Dim fontStyle As String: fontStyle = "Regular"
'Comparing word-by-word using Arrays:
WordByWord:
Dim arr1() As String
Dim arr2() As String
unmatchedA = Replace(unmatchedA, Chr(10), " ") 'Soft enter
'unmatchedA = Replace(unmatchedA, Chr(13), " ") 'Hard enter - doesn't exist within Cell.
arr1() = Split(unmatchedA, Chr(32)) 'split by blank-spaces
'MsgBox Join(arr1, ", ")
unmatchedB = Replace(unmatchedB, Chr(10), " ")
'unmatchedB = Replace(unmatchedB, Chr(13), " ")
arr2() = Split(unmatchedB, Chr(32))
For Each elem In arr2
If elem <> "" Then
If IsInArrayInt(elem, arr1) <> -1 Then
unmatPosA = InStr(unmatPosA, CellA, elem, vbTextCompare)
With CellA.Characters(unmatPosA, Len(elem)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
unmatPosA = unmatPosA + Len(elem)
End If
Else
If (InStr(unmatPosA, Mid(CellA, unmatPosA, 1), " ", vbTextCompare) Or InStr(unmatPosA, Mid(CellA, unmatPosA, 1), Chr(10), vbTextCompare)) Then
unmatPosA = unmatPosA + 1
End If
End If
Next
For Each elem In arr1
If elem <> "" Then
If IsInArrayInt(elem, arr2) <> -1 Then
unmatPosB = InStr(unmatPosB, CellB, elem, vbTextCompare)
With CellB.Characters(unmatPosB, Len(elem)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
unmatPosB = unmatPosB + Len(elem)
End If
Else
If (InStr(unmatPosB, Mid(CellB, unmatPosB, 1), " ", vbTextCompare) Or InStr(unmatPosB, Mid(CellB, unmatPosB, 1), Chr(10), vbTextCompare)) Then
unmatPosB = unmatPosB + 1
End If
End If
Next
On Error GoTo HighlightSuccessful
If CellA.Font.ColorIndex < 1 And CellB.Font.ColorIndex < 1 Then
' unmatchedA = Application.WorksheetFunction.Trim(CellA)
' unmatchedB = Application.WorksheetFunction.Trim(CellB)
unmatchedA = CellA
unmatchedB = CellB
unmatPosA = 1 'Start comparing from begining i.e. entire text.
unmatPosB = 1
Call HighlightCellText(CellA)
Call HighlightCellText(CellB)
GoTo WordByWord
End If
HighlightSuccessful:
'All done - resetting error handling:
On Error GoTo 0
End Sub
'Following hightlights the text of passed cell-range:
Sub HighlightCellText(rng As Range)
With rng.Characters(1, Len(s1)).Font
.ColorIndex = 3 'redCIndex
.fontStyle = "Bold"
End With
End Sub
'Following function removes the new line character chr(10) from both edges of the passed string then returns it.
Function TrimNewLineCharsFromEdges(ByVal s As String)
While Right(s, 1) = Chr(10)
s = Mid(s, 1, Len(s) - 1)
Wend
While Left(s, 1) = Chr(10)
s = Mid(s, 2, Len(s))
Wend
TrimNewLineCharsFromEdges = s
End Function
Sub CheckWhiteSp()
FindWhiteSpaceInString ("Hello " & Chr(10))
End Sub
'Following finds (and prints to Immediate window) any White-Spaces in passed string:
Sub FindWhiteSpaceInString(ByVal s As String)
For i = 9 To 11
If InStr(s, Chr(i)) <> 0 Then
Debug.Print "Chr(" & i & ") found in string"
End If
Next i
'Debug.Print InStr(1, [A1], Chr(13), vbTextCompare)
'MsgBox InStr(1, [B1], Chr(13), vbTextCompare)
End Sub
'Usage: IsInArrayInt("item1", arrName) -> this will check if passed arg1 is in the array-2nd-arg. Cast-INsensitive for string-comparisons.
'Returns: Position As Integer (not index number), returns -1 if element not found in array.
'e.g. If (IsInArrayInt(Cells(1, c), arr)) Then
Function IsInArrayInt(ByVal stringToBeFound As Variant, ByVal arr As Variant) As Integer
If UBound(arr) = -1 Then 'array is not initialised - if not checked here Match() will return "Type mismatch" error.
IsInArrayInt = -1
Exit Function
Else
If Not IsError(Application.Match(stringToBeFound, arr, 0)) Then
IsInArrayInt = Application.Match(stringToBeFound, arr, 0)
Else
IsInArrayInt = -1
End If
End If
End Function
Sub IsInArrayIntTest()
arr = Split("A B C D E F", " ")
'MsgBox UBound(a) 'a(0)
MsgBox IsInArrayInt("a", arr) '=> 1 as "a" is at 1st position (finds regardless of lower-case).
End Sub
'Following function replaces blank spaces and CrLf (with ¬ sign) from the passed string.
'Usage: cleanString = ReplaceWhiteSpaces(string_with_whitespaces)
Function ReplaceWhiteSpaces(ByVal s As String)
s = Replace(s, Chr(10), "¬")
s = Replace(s, Chr(13), "¬")
s = Replace(s, Chr(32), "¬")
ReplaceWhiteSpaces = s
End Function
'Following function compares two passed strings and return the postion of the first different character.
'Returns: 0 if no difference found.
'Usage: diffCharPosition = GetDiffCharPosition(string1, string2)
Function GetFirstDiffCharPosition(ByVal s1 As String, ByVal s2 As String)
If StrComp(s1, s2, vbTextCompare) = 0 Then
GetFirstDiffCharPosition = 0
Else
For i = 1 To Len(s1)
If StrComp(Mid(s1, i, 1), Mid(s2, i, 1), vbTextCompare) <> 0 Then
GetFirstDiffCharPosition = i
Exit Function
End If
Next i
End If
End Function
'Following function compares two passed strings and return the postion of the first different character.
'Returns: 0 if no difference found.
'Usage: diffLetterPosition = GetFirstDiffNonWhitespaceCharPosition(string1, string2)
Function GetFirstDiffNonWhitespaceCharPosition(ByVal s1 As String, ByVal s2 As String)
If StrComp(s1, s2, vbTextCompare) = 0 Then
GetFirstDiffNonWhitespaceCharPosition = 0
Else
i = 1: j = 1
Do
If StrComp(Mid(s1, i, 1), Mid(s2, j, 1), vbTextCompare) <> 0 Then
Exit Do
End If
If Mid(s1, i, 1) = "¬" Then
While Mid(s1, i, 1) = "¬": i = i + 1: Wend
Else
i = i + 1
End If
If Mid(s2, j, 1) = "¬" Then
While Mid(s2, j, 1) = "¬": j = j + 1: Wend
Else
j = j + 1
End If
Loop While (i <= Len(s2)) Or (j <= Len(s2))
GetFirstDiffNonWhitespaceCharPosition = i
End If
End Function
'Following inserts a new sheet and copies the ActiveCell into new sheet's [A1] & [B1]:
Sub Copy2xCellsToNewSheet()
Dim aCell As Range: Set aCell = ActiveCell
Dim bCell As Range: Set bCell = ActiveCell.Offset(0, 1)
' Set wbNew = Workbooks.Add
Dim originalSheet As Worksheet: Set originalSheet = ActiveSheet
Dim NewSh As Worksheet
Set NewSh = Sheets.Add(after:=ActiveSheet)
aCell.Copy
With NewSh.[A1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
bCell.Copy
With NewSh.[B1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'Trimming Left & Right whitespace:
[A1].Value = Trim([A1].Value)
[B1].Value = Trim([B1].Value)
End Sub
'Following inserts a new temporary workbook and copies the ActiveCell to new sheet's [A1]:
Sub CurrCellToNewTempBook()
Dim aCell As Range: Set aCell = ActiveCell
' Dim bCell As Range: Set bCell = ActiveCell.Offset(0, 1)
Dim NewWb As Workbook
Set NewWb = Workbooks.Add
Dim originalSheet As Worksheet: Set originalSheet = ActiveSheet
' Dim NewSh As Worksheet
' Set NewSh = Sheets.Add(after:=ActiveSheet)
aCell.Copy
With NewWb.Sheets(1).[A1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'bCell.Copy
With NewWb.Sheets(1).[B1]
.PasteSpecial xlPasteColumnWidths
' .PasteSpecial xlPasteFormats
' .PasteSpecial xlPasteValues
End With
'Trimming Left & Right whitespace:
[A1].Value = Trim([A1].Value)
'[B1].Value = Trim([B1].Value)
'Checking Row-Height, if needed, increase it beyond Excel limits (for better readability):
Call FixRowHeightLimit
End Sub
'Following sub merges two cells to increase/overcome the max Row-Height (409.5):
Sub FixRowHeightLimit()
ActiveSheet.Cells.VerticalAlignment = xlTop
Debug.Print [A1].RowHeight
If [A1].RowHeight > 380 Then
[A2].RowHeight = 409.5
Range("A1:A2").Merge
Range("B1:B2").Merge
End If
If [A3].RowHeight > 380 Then
[A4].RowHeight = 409.5
Range("A3:A4").Merge
Range("B3:B4").Merge
End If
[B2].Select
End Sub
'Following sub checks the basic equality of the passed parameters and shows MsgBox accordingly:
Sub BasicEqualityCheck(ByVal txt1 As String, ByVal txt2 As String, trimmedTxt As Boolean)
Dim trmMsg As String: trmMsg = ""
If trimmedTxt Then
trmMsg = ", however there are some variations in white-spaces."
End If
If txt1 = txt2 Then
MsgBox "No difference found in text" + trmMsg, vbOKOnly & vbInformation, "Text-Diff Result"
End
End If
End Sub
'Following sorts the lines/values in [A1] & [B1] cells, then copies into [A3] & [B3] cells respectively:
Sub SortThenCopyA1B1ValuesToA3B3()
Dim arr1() As String
Dim arr2() As Variant
'Creating a array list:
Set arrList = CreateObject("System.Collections.ArrayList")
'[A1] -> [A3]:
'arr1() = Split([A1], Chr(10)) 'split by Soft-Enters / new-lines
arr1() = Split([A1], vbLf) 'split by Soft-Enters / new-lines
arrList.Clear 'Clearing Array-List
' adding each lines in the array_list:
For Each element In arr1()
arrList.Add element
Next
arrList.Sort 'sorting arrList
arr2() = arrList.toarray 'Array-List elements into array.
'MsgBox Join(arr2, vbLf)
[A3] = Join(arr2, vbLf)
'[B1] -> [B3]:
arr1() = Split([B1], vbLf) 'split by Soft-Enters / new-lines
' adding each lines in the array_list:
arrList.Clear 'Clearing Array-List
For Each element In arr1()
arrList.Add element
Next
arrList.Sort 'sorting arrList
arr2() = arrList.toarray 'Array-List elements into array.
[B3] = Join(arr2, vbLf)
End Sub
'Written by: Eddie Kumar Shrivastava
'Main method: Sub CompareAndHighlightDiffs() - this is the main/parent function that calls relevant dependencies/sub-routines.
'Description: Utility to quickly find character-by-character differences between two paragraphs/code snippets in Cells [A1] & [B1].
'Usage: In Excel spreadsheet copy-paste the two paragraphs/code snippets (that need to be compared) in Cells [A1] & [B1], then run the CompareAndHighlightDiffs() function.
'Date Created: 29-09-2017
'Date Modified: 23-10-2017
'Version: 1.2
'Version info/Change Log:
' - Added feature to span/merge multiple cells, when text overflows out of first cell.
' - Fixed issue with recognition of the repeating words.
'******************************************************************************************
'Following (CompareAndHighlightDiffs) is the main/parent function that calls relevant dependencies/sub-routines.
'TEXT COMPARISON: Following sub compares text and highlights the differences between cells A1 against B1:
Sub CompareAndHighlightDiffs()
Call BasicEqualityCheck([A1], [B1], False)
'TRIMMING WHITE-SPACE:
'Trimming Left & Right BLANKS:
[A1].Value = Trim([A1].Value)
[B1].Value = Trim([B1].Value)
'Trimming Left & Right NEWLINE-CHARS:
[A1].Value = TrimNewLineCharsFromEdges([A1].Value)
[B1].Value = TrimNewLineCharsFromEdges([B1].Value)
Call SortThenCopyA1B1ValuesToA3B3
Call CompareAndHighlightPassedValues([A1], [B1])
Call CompareAndHighlightPassedValues([A3], [B3])
Call FixRowHeightLimit
End Sub
Sub CompareAndHighlightPassedValues(CellA As Range, CellB As Range)
'------------------------
'CHAR-BY-CHAR Comparison:
'------------------------
Dim posA, posRevA As Integer
Dim posB, posRevB As Integer
'Dim s1, s2 As String
's1 = CellA
's2 = CellB
s1 = CellA.Value
s2 = CellB.Value
s1 = ReplaceWhiteSpaces(s1)
s2 = ReplaceWhiteSpaces(s2)
trimmedTxt1 = Replace(s1, "¬", "")
trimmedTxt2 = Replace(s2, "¬", "")
Call BasicEqualityCheck(trimmedTxt1, trimmedTxt2, True)
'Hightlighting entire text of both cells:
Call HighlightCellText(CellA)
Call HighlightCellText(CellB)
posA = GetFirstDiffNonWhitespaceCharPosition(s1, s2)
posB = GetFirstDiffNonWhitespaceCharPosition(s2, s1)
s1 = StrReverse(s1)
s2 = StrReverse(s2)
' Debug.Print s1
posRevA = GetFirstDiffNonWhitespaceCharPosition(s1, s2)
posRevB = GetFirstDiffNonWhitespaceCharPosition(s2, s1)
'CellA Formatting:
'With CellA.Characters(posA, Len(s1) - ((posRevA + posA) - 2)).Font 'character in the middle.
With CellA.Characters(1, posA - 1).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' If Len(s1) > (posA + posRevA) - 2 Then
With CellA.Characters(Len(s1) - (posRevA - 2), Len(s1)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' End If
'CellB Formatting:
'With CellB.Characters(posB, Len(s1) - ((posRevB + pos) - 2)).Font 'characters in the middle.
With CellB.Characters(1, posB - 1).Font
.ColorIndex = 0 'black Index
.fontStyle = "Regular"
End With
' If Len(s2) > (posB + posRevB) - 2 Then
With CellB.Characters(Len(s2) - (posRevB - 2), Len(s2)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
' End If
'
'------------------------
'WORD-BY-WORD Comparison (for unmatched words):
'------------------------
' MsgBox Mid(CellA, pos, Len(s1) - ((posRevA + pos) - 2)) 'characters in the middle.
' MsgBox Mid(CellB, pos, Len(s2) - ((posRevA + pos) - 2)) 'characters in the middle.
'Starting positions of Unmatch-text:
Dim unmatPosA, unmatPosB As Integer
unmatPosA = posA 'Start comparing from posA - where first diff-char was found.
unmatPosB = posB
'Initialisation of the variable holding Unmatched-text:
Dim unmatchedA, unmatchedB As String 'unmatched characters in the middle.
If Len(s1) > ((posRevA + posA) - 2) Then
unmatchedA = WorksheetFunction.Trim(Mid(CellA, posA, Len(s1) - ((posRevA + posA) - 2)))
Else
unmatchedA = ""
End If
If Len(s2) > ((posRevB + posB) - 2) Then
unmatchedB = WorksheetFunction.Trim(Mid(CellB, posB, Len(s2) - ((posRevB + posB) - 2)))
Else
unmatchedB = ""
End If
Dim cIndex As Integer: cIndex = 0
Dim fontStyle As String: fontStyle = "Regular"
'Comparing word-by-word using Arrays:
WordByWord:
Dim arr1() As String
Dim arr2() As String
unmatchedA = Replace(unmatchedA, Chr(10), " ") 'Soft enter
'unmatchedA = Replace(unmatchedA, Chr(13), " ") 'Hard enter - doesn't exist within Cell.
arr1() = Split(unmatchedA, Chr(32)) 'split by blank-spaces
'MsgBox Join(arr1, ", ")
unmatchedB = Replace(unmatchedB, Chr(10), " ")
'unmatchedB = Replace(unmatchedB, Chr(13), " ")
arr2() = Split(unmatchedB, Chr(32))
For Each elem In arr2
If elem <> "" Then
If IsInArrayInt(elem, arr1) <> -1 Then
unmatPosA = InStr(unmatPosA, CellA, elem, vbTextCompare)
With CellA.Characters(unmatPosA, Len(elem)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
unmatPosA = unmatPosA + Len(elem)
End If
Else
If (InStr(unmatPosA, Mid(CellA, unmatPosA, 1), " ", vbTextCompare) Or InStr(unmatPosA, Mid(CellA, unmatPosA, 1), Chr(10), vbTextCompare)) Then
unmatPosA = unmatPosA + 1
End If
End If
Next
For Each elem In arr1
If elem <> "" Then
If IsInArrayInt(elem, arr2) <> -1 Then
unmatPosB = InStr(unmatPosB, CellB, elem, vbTextCompare)
With CellB.Characters(unmatPosB, Len(elem)).Font
.ColorIndex = 0 'blackCIndex
.fontStyle = "Regular"
End With
unmatPosB = unmatPosB + Len(elem)
End If
Else
If (InStr(unmatPosB, Mid(CellB, unmatPosB, 1), " ", vbTextCompare) Or InStr(unmatPosB, Mid(CellB, unmatPosB, 1), Chr(10), vbTextCompare)) Then
unmatPosB = unmatPosB + 1
End If
End If
Next
On Error GoTo HighlightSuccessful
If CellA.Font.ColorIndex < 1 And CellB.Font.ColorIndex < 1 Then
' unmatchedA = Application.WorksheetFunction.Trim(CellA)
' unmatchedB = Application.WorksheetFunction.Trim(CellB)
unmatchedA = CellA
unmatchedB = CellB
unmatPosA = 1 'Start comparing from begining i.e. entire text.
unmatPosB = 1
Call HighlightCellText(CellA)
Call HighlightCellText(CellB)
GoTo WordByWord
End If
HighlightSuccessful:
'All done - resetting error handling:
On Error GoTo 0
End Sub
'Following hightlights the text of passed cell-range:
Sub HighlightCellText(rng As Range)
With rng.Characters(1, Len(s1)).Font
.ColorIndex = 3 'redCIndex
.fontStyle = "Bold"
End With
End Sub
'Following function removes the new line character chr(10) from both edges of the passed string then returns it.
Function TrimNewLineCharsFromEdges(ByVal s As String)
While Right(s, 1) = Chr(10)
s = Mid(s, 1, Len(s) - 1)
Wend
While Left(s, 1) = Chr(10)
s = Mid(s, 2, Len(s))
Wend
TrimNewLineCharsFromEdges = s
End Function
Sub CheckWhiteSp()
FindWhiteSpaceInString ("Hello " & Chr(10))
End Sub
'Following finds (and prints to Immediate window) any White-Spaces in passed string:
Sub FindWhiteSpaceInString(ByVal s As String)
For i = 9 To 11
If InStr(s, Chr(i)) <> 0 Then
Debug.Print "Chr(" & i & ") found in string"
End If
Next i
'Debug.Print InStr(1, [A1], Chr(13), vbTextCompare)
'MsgBox InStr(1, [B1], Chr(13), vbTextCompare)
End Sub
'Usage: IsInArrayInt("item1", arrName) -> this will check if passed arg1 is in the array-2nd-arg. Cast-INsensitive for string-comparisons.
'Returns: Position As Integer (not index number), returns -1 if element not found in array.
'e.g. If (IsInArrayInt(Cells(1, c), arr)) Then
Function IsInArrayInt(ByVal stringToBeFound As Variant, ByVal arr As Variant) As Integer
If UBound(arr) = -1 Then 'array is not initialised - if not checked here Match() will return "Type mismatch" error.
IsInArrayInt = -1
Exit Function
Else
If Not IsError(Application.Match(stringToBeFound, arr, 0)) Then
IsInArrayInt = Application.Match(stringToBeFound, arr, 0)
Else
IsInArrayInt = -1
End If
End If
End Function
Sub IsInArrayIntTest()
arr = Split("A B C D E F", " ")
'MsgBox UBound(a) 'a(0)
MsgBox IsInArrayInt("a", arr) '=> 1 as "a" is at 1st position (finds regardless of lower-case).
End Sub
'Following function replaces blank spaces and CrLf (with ¬ sign) from the passed string.
'Usage: cleanString = ReplaceWhiteSpaces(string_with_whitespaces)
Function ReplaceWhiteSpaces(ByVal s As String)
s = Replace(s, Chr(10), "¬")
s = Replace(s, Chr(13), "¬")
s = Replace(s, Chr(32), "¬")
ReplaceWhiteSpaces = s
End Function
'Following function compares two passed strings and return the postion of the first different character.
'Returns: 0 if no difference found.
'Usage: diffCharPosition = GetDiffCharPosition(string1, string2)
Function GetFirstDiffCharPosition(ByVal s1 As String, ByVal s2 As String)
If StrComp(s1, s2, vbTextCompare) = 0 Then
GetFirstDiffCharPosition = 0
Else
For i = 1 To Len(s1)
If StrComp(Mid(s1, i, 1), Mid(s2, i, 1), vbTextCompare) <> 0 Then
GetFirstDiffCharPosition = i
Exit Function
End If
Next i
End If
End Function
'Following function compares two passed strings and return the postion of the first different character.
'Returns: 0 if no difference found.
'Usage: diffLetterPosition = GetFirstDiffNonWhitespaceCharPosition(string1, string2)
Function GetFirstDiffNonWhitespaceCharPosition(ByVal s1 As String, ByVal s2 As String)
If StrComp(s1, s2, vbTextCompare) = 0 Then
GetFirstDiffNonWhitespaceCharPosition = 0
Else
i = 1: j = 1
Do
If StrComp(Mid(s1, i, 1), Mid(s2, j, 1), vbTextCompare) <> 0 Then
Exit Do
End If
If Mid(s1, i, 1) = "¬" Then
While Mid(s1, i, 1) = "¬": i = i + 1: Wend
Else
i = i + 1
End If
If Mid(s2, j, 1) = "¬" Then
While Mid(s2, j, 1) = "¬": j = j + 1: Wend
Else
j = j + 1
End If
Loop While (i <= Len(s2)) Or (j <= Len(s2))
GetFirstDiffNonWhitespaceCharPosition = i
End If
End Function
'Following inserts a new sheet and copies the ActiveCell into new sheet's [A1] & [B1]:
Sub Copy2xCellsToNewSheet()
Dim aCell As Range: Set aCell = ActiveCell
Dim bCell As Range: Set bCell = ActiveCell.Offset(0, 1)
' Set wbNew = Workbooks.Add
Dim originalSheet As Worksheet: Set originalSheet = ActiveSheet
Dim NewSh As Worksheet
Set NewSh = Sheets.Add(after:=ActiveSheet)
aCell.Copy
With NewSh.[A1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
bCell.Copy
With NewSh.[B1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'Trimming Left & Right whitespace:
[A1].Value = Trim([A1].Value)
[B1].Value = Trim([B1].Value)
End Sub
'Following inserts a new temporary workbook and copies the ActiveCell to new sheet's [A1]:
Sub CurrCellToNewTempBook()
Dim aCell As Range: Set aCell = ActiveCell
' Dim bCell As Range: Set bCell = ActiveCell.Offset(0, 1)
Dim NewWb As Workbook
Set NewWb = Workbooks.Add
Dim originalSheet As Worksheet: Set originalSheet = ActiveSheet
' Dim NewSh As Worksheet
' Set NewSh = Sheets.Add(after:=ActiveSheet)
aCell.Copy
With NewWb.Sheets(1).[A1]
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'bCell.Copy
With NewWb.Sheets(1).[B1]
.PasteSpecial xlPasteColumnWidths
' .PasteSpecial xlPasteFormats
' .PasteSpecial xlPasteValues
End With
'Trimming Left & Right whitespace:
[A1].Value = Trim([A1].Value)
'[B1].Value = Trim([B1].Value)
'Checking Row-Height, if needed, increase it beyond Excel limits (for better readability):
Call FixRowHeightLimit
End Sub
'Following sub merges two cells to increase/overcome the max Row-Height (409.5):
Sub FixRowHeightLimit()
ActiveSheet.Cells.VerticalAlignment = xlTop
Debug.Print [A1].RowHeight
If [A1].RowHeight > 380 Then
[A2].RowHeight = 409.5
Range("A1:A2").Merge
Range("B1:B2").Merge
End If
If [A3].RowHeight > 380 Then
[A4].RowHeight = 409.5
Range("A3:A4").Merge
Range("B3:B4").Merge
End If
[B2].Select
End Sub
'Following sub checks the basic equality of the passed parameters and shows MsgBox accordingly:
Sub BasicEqualityCheck(ByVal txt1 As String, ByVal txt2 As String, trimmedTxt As Boolean)
Dim trmMsg As String: trmMsg = ""
If trimmedTxt Then
trmMsg = ", however there are some variations in white-spaces."
End If
If txt1 = txt2 Then
MsgBox "No difference found in text" + trmMsg, vbOKOnly & vbInformation, "Text-Diff Result"
End
End If
End Sub
'Following sorts the lines/values in [A1] & [B1] cells, then copies into [A3] & [B3] cells respectively:
Sub SortThenCopyA1B1ValuesToA3B3()
Dim arr1() As String
Dim arr2() As Variant
'Creating a array list:
Set arrList = CreateObject("System.Collections.ArrayList")
'[A1] -> [A3]:
'arr1() = Split([A1], Chr(10)) 'split by Soft-Enters / new-lines
arr1() = Split([A1], vbLf) 'split by Soft-Enters / new-lines
arrList.Clear 'Clearing Array-List
' adding each lines in the array_list:
For Each element In arr1()
arrList.Add element
Next
arrList.Sort 'sorting arrList
arr2() = arrList.toarray 'Array-List elements into array.
'MsgBox Join(arr2, vbLf)
[A3] = Join(arr2, vbLf)
'[B1] -> [B3]:
arr1() = Split([B1], vbLf) 'split by Soft-Enters / new-lines
' adding each lines in the array_list:
arrList.Clear 'Clearing Array-List
For Each element In arr1()
arrList.Add element
Next
arrList.Sort 'sorting arrList
arr2() = arrList.toarray 'Array-List elements into array.
[B3] = Join(arr2, vbLf)
End Sub
'------------x------------
No comments:
Post a Comment