Useful VBA Utilities for Microsoft Excel (Core Eddie-Code)

Useful VBA Utilities for Microsoft Excel (Core Eddie-Code):

Author: Eddie Kumar Shrivastava

'Useful VBA Utilities for Microsoft Excel (Core Eddie-Code):

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

'Written by:    Eddie Kumar Shrivastava

'Description:   Eddie-Tools & Utilities to speed up the data-processing/formatting etc. in the Excel.

'Readonly link: https://officeapptips.blogspot.com/2022/01/useful-vba-utilities-for-microsoft.html

'Editable-Repo: https://www.blogger.com/u/1/blog/post/edit/5593580733288490407/7516263398716064107

'Date Created:  16-01-2010

'Last Modified: 24-11-2023

'Version:       21.9

'Version info/Change Log/Subs-List:

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

'             SUBs                      -  Keyboard-Shortcuts Assigned

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

'''''''''''''''''''''''' LIST OF ALL SUBs & FUNCTIONs ''''''''''''''''''''''''

'-      Function GetExecutionDuration_TurnOnTimer(ByVal switch As Boolean)

'-      Sub Testing_GetExecutionDuration_TurnOnTimer()

'-      Function TurnOffOtherExcelActivities(switch As Boolean)

'-      Sub SetFullScreen(fullScr As Boolean)

'-      Function ColumnNumberToLetter(ByVal colNum As Integer)

'-      Function ColumnLetterToNumber(ByVal colLetter As String)

'-      Function ColumnNum2Letter(iCol As Integer)

'-      Function ColumnNum2Letter(iCol As Integer)

'-      Function GetColumnNumberByHeaderName(headerName As String)

'-      Function GetTargetColumn()

'-      Function hasAlphabetsOnly(s As String)

'-      Function hasAlphabets(s As String)

'-      Sub WriteToClipboard(ByVal text As String)

'-      Sub PasteFromClipboardToA1()

'-      Sub PastePlainText()

'-      Sub CreateCopyOfCurrentSheet()

'-      Sub DeleteAllButCurrentSheet()

'-      Sub DeleteAllButActiveSheet()

'-      Sub UnhideRows()

'-      Sub JumpToLastColumn()

'-      Sub ConfirmRun(subName)

'-      Sub SetFontCalibri10()

'-      Sub PasteAndFormatTable()

'-      Sub SplitColsAndFormat()

'-      Sub FormatEdTableWithHeader() / EdFormat

'-      Sub UnformatData()

'-      Sub FormatAbortedRows()

'-      Sub MaxColumnWide60()

'-      Sub ParseTextToDates()

'-      Sub DateFormattingForTime()

'-      Sub CheckIfDateHasTimePart()

'-      Sub GetValueFromClipboard()

'-      Sub CaptureAndResumeSheetView()

'-      Sub ColorShadeAlternateRows(rng As Range)

'-      Sub ListFiles()

'-      Sub 'Rename_Files()

'-      Function IsWorkBookOpen(fileName As String)

'-      Function SheetExists(n As String)

'-      Sub BulkConvertionFromXlsIntoXlsmOrXlsx()

'-      Sub ExportAsTxtTabDelimited()

'-      Sub ExportAsCSV()

'-      Sub ExportAsCSV_Old()

'-      Sub SaveAsXlsx() 'ExportAsXlsx()

'-      Sub SplitWorkbookExportSheetsAsXlsx()

'-      Function strLegalFileName(strFileNameIn As String)

'-      Sub CompareAandBColumnsHighlightNoMatches()       'At cell-level

'-      Sub CompareSelectedColumnsAndHighlightNoMatches()

'-      Sub CompareAndHighlightDiffs()                    'At character-level (advanced but slow)

'-      Sub DedupeKeywordsAndCopyInNewColumn()

'-      Sub DeDupContactsBeforeImport()

'-      Sub FilterAndShowRowsContainingSelectedText()  'or Sub FilterByWords-List()

'-      Sub FilterAndShowRowsContainingSelectedText__SingleWordSearch_Ver1()

'-      Sub FilterAndShowRowsContainingSelectedText_AppliesToEntireSheet_OLD()

'-      Sub FiterSouthEastAndLondonPostcodesOnly()

'-      Sub DeleteExtraWhitespaceBetweenWords()

'-      Sub DeleteEmptyCellsCollapseEntireTable()

'-      Sub DeleteEmptyCellsCollapseSingleColumn()

'-      Sub MoveAllDataInOneColumnA()

'-      Sub MoveCellValuesIntoColA()

'-      Sub DeleteEmptyRows()

'-      Sub DeleteEmptyColumns()

'-      Sub MoveRowToAnotherSheet()

'-      Sub MoveRowFromIncompleteToCompleteSheet()

'-      Sub SortByCountryUKonTop()

'-      Sub SortByCountryCode()

'-      Sub ChangeCase2ProperIf1stCharLower_OLDER()

'-      Sub SplitAndJoinArray()

'-      Sub ChangeCase2ProperIf1stCharLower()

'-      Function IsInArray(ByVal stringToBeFound As String, ByVal arr As Variant)

'-      Function IsInArrayInt(ByVal stringToBeFound As Variant, ByVal arr As Variant)

'-      Sub IsInArrayIntTest()

'-      Sub DeleteCols_RenameCols_SortByMailName()

'-      Sub DeleteCols4Communigator()

'-      Sub DeleteUnnecessaryCols()

'-      Sub Delete1AlphabetLongFirstName()

'-      Sub DelCol_FormatsForPostalMailingList()

'-      Sub SwapCol2with3()

'-      Sub DedupeOnEmail()

'-      Sub RenameTrilogyCols()

'-      Sub RenameCols_SortByMailName()

'-      Sub DelLenCols()

'-      Sub AddLenCols()

'-      Sub DelLenCols()

'-      Sub SortDesc()

'-      Sub ValidateTelNumber()

'-      Sub ValidateEmail()

'-      Sub HighlightCell(cellAddr As Range)

'-      Sub ValidateIfEUCountries()

'-      Sub ValidateHighlightEUCountries()

'-      Sub TestLikeOperator()

'-      Sub ValidateCountryNames()

'-      Function EdFuzzyMatch(s1 As String, s2 As String)

'-      Sub MatchFunctionErrorHandlingTest()

'-      Sub CollapseTableStructureLeftAglignData_byNavigating()

'-      Sub CollapseTableStructureLeftAglignData()

'-      Sub DuplicateRowFinder()

'-      Sub InsertUniqueValues_RemoveDupes()

'-      Sub BouncedEmailListUpdate()

'-      Sub UnsubscribedEmailListUpdate2()

'-      Sub UnsubscribedEmailListUpdate()

'-      Sub goto_curr_week()

'-      Sub InsertSubTotalOfVisibleOnlyCells()

'-      Sub DedupeRowsBy1PositionsPerOrganisation()

'-      Sub DedupeSubscribersWithBothInvoiceAndDeliveryAddr()

'-      Sub DedupeRowsBySimpleNextPreviousValueComparison()

'-      Sub DedupeAddressInvoiceVsDeliveryV1()

'-      Sub DedupeRowsBySimpleNextPreviousValueComparison()

'-      Sub DedupeAddressInvoiceVsDeliveryV2()

'-      Sub DedupeRowsBySimpleNextPreviousValueComparison()

'-      Sub DedupeAddressInvoiceVsDeliveryV3()

'-      Sub CheckIfArrayElementInitialized()

'-      Sub CheckIfVariableAssigned()

'-      Sub CheckEmptyString()

'-      Sub FirstAndLastRowsInUsedRange()

'-      Sub HideMultipleRowsAtOnce()

'-      Sub FindInUnionedRange()

'-      Sub SpecialCellsTest()

'-      Function NextColourIndex()

'-      Sub InitBrightColourIndex()

'-      Sub InitDarkColourIndex()

'-      Sub DeleteDrawingObjects()

'-      Sub StratifyByYears()

'-      Sub CopyColumnValuesOnlyInEmptyCells()

'-      Sub FindAndReplaceKeysWithValues()

'-      Sub SplitJoinFunctionsCheck()

'-      Sub MonthlyReportSortBySubs()

'-      Sub MonthlyReportSortBySubs_WithLDMH()

'-      Sub ExtractFirstName()

'-      Sub ExtractSubstring()

'-      Sub SortByColour()

'-      Function ColumnsToText(rng As Range, Optional DelimitBy As String = " ")

'-      Sub ConcatenateLeftCells()

'-      Sub ConcatenateLeftCellsTillLastRow()

'-      Sub ColumnToCommaSeparatedValuesIntoNextColumn()

'-      Sub DeleteIfNextCellIsEmpty()

'-      Sub DeleteIfNextCellHasValue()

'-      Sub CopyXlsbFileIntoUsersAppDataFolder()

'-      Function CreateFolderCheckIfNotExists(folderNameWithFullPath As String)

'-      Sub AddBouncedEmailsPercentColumn()

'-      Sub BringLastStaggeredColumnsValuesToFirstColumnA()

'-      Function GetLastRow(Sh As Worksheet)

'-      Function GetLastCol(Sh As Worksheet)

'-      Sub CopyRangeFromMultiWorksheets()

'-      Sub ApplyColourScaleOnColumn(c As String)

'-      Sub SplitRowsIn1000sAndExportAsCSV()

'-      Sub ExportCurrSheetAsCSV_WithoutPrompt(wBookPath As String)

'-      Sub SimpleRangeCheck()

'-      Sub Select1000Rows()

'-      Sub SpecFormatTmp()

'-      Sub GetSpecId()

'-      Sub NonStandardCharactersCheckInSheet(), NonStandardCharactersCheckInSpecifiedColumn()

'-      Sub NonStandardCharactersCheckInSheet()  'Sub SpotDodgyCharsInSheet()

'-      Sub NonStandardCharactersCheckInSpecifiedColumn()     'SpotDodgyCharsInSpecCol()

'-      Sub SpotDodgyCharPositionInTargetCell()

'-      Sub SpotDodgyCharPositionInTargetCell_CheckOnly()

'-      Sub StatusBarExample()

'-      Sub ProgressBarUsingForm()

'-      Sub ShowProgressBar()

'-      Sub ShowProgressBar()

'-      Sub ProgressBarUsingForm()

'-      Sub PrintArrayIn1Cell(myArr As Variant, cell As Range)

'-      Sub PrintArrayInRange(myArr As Variant, cell As Range)

'-      Sub TestPrintArrayIntoSheet()

'-      Sub UnassignedVsEmptyVsNull()

'-      Sub ErrHandlerInLoop()

'-      Sub ErrHandler()

'-      Sub SleepTest()

'-      Sub WaitTest()

'-      Sub getPathOfCurrentFile()

'-      Sub CompareAndHighlightDiffs()

'-      Sub CompareAndHighlightPassedValues(CellA As Range, CellB As Range)

'-      Sub HighlightCellText(rng As Range)

'-      Function TrimNewLineCharsFromEdges(ByVal s As String)

'-      Sub CheckWhiteSpaceInString()

'-      Sub FindWhiteSpaceInString(ByVal s As String)

'-      Function ReplaceWhiteSpaces(ByVal s As String)

'-      Function GetFirstDiffCharPosition(ByVal s1 As String, ByVal s2 As String)

'-      Function GetFirstDiffNonWhitespaceCharPosition(ByVal s1 As String, ByVal s2 As String)

'-      Sub Copy2xCellsToNewSheet()

'-      Sub CurrCellToNewTempBook()

'-      Sub FixRowHeightLimit()

'-      Sub BasicEqualityCheck(ByVal txt1 As String, ByVal txt2 As String, trimmedTxt As Boolean)

'-      Sub SortThenCopyA1B1ValuesToA3B3()

'''''''''''''''''''''''' RE-USABLE ED-LIBS / EdFunctions / UTILS ''''''''''''''

'-   Sub x()             - Ctrl + Shift + F

'''''''''''''''''''''''' QUICK EXPORTS ''''''''''''''''''''''''

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

'''''''''''''''''''''''' Ed-Useful-Excel-VBA-Code-Sample / Extras ''''''''''''''''

'-   Sub y()             -

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

''Following module-level global vars are used in Sub InitBrightColourIndex() and NextColourIndex() subs

Public BrightColourIndexes() As Variant

Public DarkColourIndexes() As Variant

Private colourIdx As Integer

'Private colourIdx As Integer: colourIdx = 4

'Following global variable is used by Function GetExecutionDuration_TurnOnTimer()

Public startTime As Single

'Following global declaration is required by the Sleep() function:

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'needed by Sleep() function - for Office 64 Bit

'''''''''''''''''''Useful one-liners:

    'MsgBox CreateObject("Scripting.FileSystemObject").GetFolder("C:\tmp").Files.count      'returns file-counts in folder

    'usrDesktopFolder = CreateObject("WScript.Shell").specialfolders("Desktop")             'returns user's Desktop folder as String

'These Modular / Global level variables must be declared ABOVE the subs they are being used within.

''Capturing current status:

''Following module-level global vars are used in sub FormatEdTableWithHeader()  'NOT CAPTURING FOR BETTER PORTABILITY OF THE CODE

    ' Private sheetIdx As Integer

    ' Private cellAddr As String

    ' Private scrollRows As Integer

    ' Private scrollCol As Integer

    ' currCalc = Application.Calculation

    ' currStatusBar = Application.DisplayStatusBar

    ' currEvents = Application.EnableEvents

    ' currPageBreaks = ActiveSheet.DisplayPageBreaks

'''''''''''''''''''''''''''''''''''''

'Following function, when called passing True will turn-on the stop-watch, and when called passing False will return the Lapsed time (since the start-time)

'Usage:

'   GetExecutionDuration_TurnOnTimer(True) 'turn on stop-watch.

'   MsgBox ("your_message_here." & vbNewLine & vbNewLine & "The code took " & GetExecutionDuration_TurnOnTimer(False) & " seconds to run.")

Function GetExecutionDuration_TurnOnTimer(ByVal switch As Boolean)

'Following variable is declared at global level:

'Public startTime As Single

    If switch Then

        startTime = Timer                               ' Get start time.

    Else

        Dim endTime As Single

        endTime = Timer                                 ' Get end time.

        GetExecutionDuration_TurnOnTimer = Format(endTime - startTime, "Fixed") 'returning lapsed time.

    End If

End Function

Sub Testing_GetExecutionDuration_TurnOnTimer()

    GetExecutionDuration_TurnOnTimer (True)

    MsgBox "wait a sec."

    MsgBox "you waited: " & GetExecutionDuration_TurnOnTimer(False) & " seconds."

End Sub

'Following function toggles all (possible) activities of Excel except running VBA code in order to speed up the execution.

'ARGUMENTS:

    'True: turns off other activities.

    'False: turns on other activities.

'USAGE:

    'TurnOffOtherExcelActivities(True)  OR  TurnOffOtherExcelActivities(False)

'Credit/idea taken from: "http://datapigtechnologies.com/blog/index.php/ten-things-you-can-do-to-speed-up-your-excel-vba-code/"

Function TurnOffOtherExcelActivities(switch As Boolean)

    If Not Application.ActiveProtectedViewWindow Is Nothing Then

        Application.ActiveProtectedViewWindow.Edit

    End If

    If switch Then

        Application.Calculation = xlCalculationManual

        Application.EnableEvents = False

        Application.ScreenUpdating = False

        Application.DisplayStatusBar = False

        Application.DisplayAlerts = False

'        If ActiveSheet.DisplayPageBreaks Then

'            ActiveSheet.DisplayPageBreaks = False

'        End If

    Else

        Application.Calculation = xlCalculationAutomatic

        Application.EnableEvents = True

        Application.ScreenUpdating = True

        Application.DisplayStatusBar = True

        Application.DisplayAlerts = True

'        ActiveSheet.DisplayPageBreaks = True

    End If

End Function

'Use following to enable the presentation mode / full-screen: (Note: Disable script is placed in 'UnhindeRows' sub)

'Usage: SetFullScreen(True) -- this will enable the Excel's full screen.

Sub SetFullScreen(fullScr As Boolean)

    If fullScr Then

        ActiveWindow.DisplayGridlines = False

        ActiveWindow.DisplayHeadings = False

        Application.DisplayFormulaBar = False

        Application.DisplayFullScreen = True

    Else

        ActiveWindow.DisplayGridlines = True

        ActiveWindow.DisplayHeadings = True

        Application.DisplayFormulaBar = True

        Application.DisplayFullScreen = False

    End If

End Sub

'Column Number to Column Name/Letters:

'Usage: MsgBox ColumnNumberToLetter(1)

Function ColumnNumberToLetter(ByVal colNum As Integer)

   ColumnNumberToLetter = Split(Cells(, colNum).Address, "$")(1)

End Function

'Column Column Name/Letters to Number:

'Usage: MsgBox ColumnLetterToNumber("AA")

Function ColumnLetterToNumber(ByVal colLetter As String)

    ColumnLetterToNumber = Range(colLetter & 1).Column

End Function

'------------https://support.microsoft.com/en-gb/kb/833402

'Function ColumnNum2Letter(iCol As Integer) As String

Function ColumnNum2Letter(iCol As Integer) As String

   Dim iAlpha As Integer

   Dim iRemainder As Integer

   iAlpha = Int(iCol / 27)

   iRemainder = iCol - (iAlpha * 26)

   If iAlpha > 0 Then

      ColumnNum2Letter = Chr(iAlpha + 64)

   End If

   If iRemainder > 0 Then

      ColumnNum2Letter = ColumnNum2Letter & Chr(iRemainder + 64)

   End If

End Function

'This function returns the column-number of the column that contains "email" or "userdefined4" in its header, returns 0 otherwise.

'ASSUMPTION:

    'This function assumes that caller table has a header row on top within used-range (it may have empty rows above).

'USAGE:

'    Dim emailCol As Integer: emailCol = GetColumnNumberByHeaderName("email")  'if not found then 0 is returned.

Function GetColumnNumberByHeaderName(headerName As String)

    Dim lastCol, c  As Integer: lastCol = Cells(ActiveSheet.UsedRange.Row, Columns.count).End(xlToLeft).Column

    GetColumnNumberByHeaderName = 0

    For c = 1 To lastCol

        'Email: If InStr(1, CStr(Cells(1, c)), "email", vbTextCompare) > 0 Or InStr(1, CStr(Cells(1, c)), "userdefined4", vbTextCompare) > 0 Then

        If InStr(1, CStr(Cells(1, c)), headerName, vbTextCompare) > 0 Then

            GetColumnNumberByHeaderName = c

            Exit For

        End If

    Next c

End Function

'This function prompts user to input a column-letter, then returns containing column-letter a string

  ' in case of error (or if user's empty-entry) it returns an empty-sting.

'USAGE:

'    Dim strCol As String: strCol = GetTargetColumn()

'    If strCol = "" Then

'        End

'    End If

Function GetTargetColumn()

    Dim col As Variant

GetCol:

    col = Trim(InputBox(Prompt:="Enter the target Column-Letter (such as 'A' for 1st Column)"))    'Without "APPLICATION." Cancel button retuns empty-string AND arrows-key becomes deactive hence don't reference cell-addresses.

    'col = Trim(Application.InputBox(Prompt:="Enter the target Column-Letter (such as 'A' for 1st Column)")) 'With "APPLICATION." Cancel button retuns False AND pressing arrows-keys insert cell-references in the Inputbox.

    'Debug.Print TypeName(col) & " - " & col

    If col = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        GetTargetColumn = ""

    ElseIf col = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        GetTargetColumn = ""

    ElseIf IsNumeric(col) Or Len(col) > 2 Or IsNumeric(Left(col, 1)) Or IsNumeric(Right(col, 1)) Then

        MsgBox "Invalid column letter, please enter only text - max 2 letters (not a number, space, special chars etc.)"

        GoTo GetCol

    Else

        GetTargetColumn = col

    End If

End Function

'This function returs true if passed argument only contains alphabets i.e. arg Like "[a-zA-Z]+"

'Usage:    MsgBox hasAlphabets("abcd32")

Function hasAlphabetsOnly(s As String) As Boolean

    hasAlphabetsOnly = True

    For intPos = 1 To Len(s)

        Select Case Asc(Mid(s, intPos, 1)) 'If Not Mid(s, intPos, 1) Like "[a-zA-Z]" Then

            Case 65 To 90, 97 To 122

                'hasAlphabetsOnly = True

            Case Else

                hasAlphabetsOnly = False

                Exit For

        End Select

    Next intPos

End Function

'This function returs true if passed argument only contains alphabets i.e. arg Like "[a-zA-Z]+"

'Usage:    MsgBox hasAlphabets("abcd32")

Function hasAlphabets(s As String) As Boolean

    hasAlphabets = True

    For intPos = 1 To Len(s)

        If Not Mid(s, intPos, 1) Like "[a-zA-Z]" Then

                hasAlphabets = False

                Exit For

        End If

    Next intPos

End Function

'Following writes passed argument into the Clipboard.

'Usage:     WriteToClipboard "asdf"

Public Sub WriteToClipboard(ByVal text As String)

    CreateObject("htmlfile").ParentWindow.ClipboardData.SetData "text", text

End Sub

'Following pastes the Clipboard contents from the range [A1] (normally splitting columns by Tabs):

Sub PasteFromClipboardToA1()

    ' Error handler

    On Error GoTo PasteFailed

    Range("A1").Select

    ActiveSheet.Paste

    

    ' Error-Handler Label:

PasteFailed:

End Sub

'Following pastes the Clipboard contents as plain-text:

Sub PastePlainText()

    'PastePlainText

    Selection.PasteSpecial xlPasteValues

End Sub

'Creates copy of current sheet and places next to it.

Sub CreateCopyOfCurrentSheet()

    Dim sName As String: sName = ActiveSheet.name

    If Len(sName) >= 30 Then

        sName = Left(sName, Len(sName) - 3)

        While SheetExists(sName)

            sName = sName & WorksheetFunction.RandBetween(0, 999)

        Wend

        ActiveSheet.name = sName

    End If

    ActiveSheet.Copy after:=ActiveSheet

    'Sheets(sName).Copy after:=Sheets(sName)

End Sub

'Use with caution: Delete all sheets except current sheet:

Sub DeleteAllButCurrentSheet()

    Dim currSheetName As String: currSheetName = ActiveSheet.name

    Dim ans As String

    ans = MsgBox("BEWARE:" & vbNewLine & vbNewLine & "Are you sure you want to proceed with deletion of all sheets except current sheet: """ & currSheetName & """", vbYesNo + vbCritical + vbDefaultButton2, "Confirm Sheets Deletion")

    If ans = vbNo Then

        End

    End If

'    On Error Resume Next

'    ActiveWorkbook.Save 'just in case if undo of deletion is needed.

'    On Error GoTo 0

'   Sub DeleteAllButActiveSheet()

    Application.DisplayAlerts = False

    For Each ws In Worksheets

      If currSheetName <> ws.name Then

        ws.Delete

      End If

    Next ws

    Application.DisplayAlerts = True

    'MsgBox ("Deletion complete.  If unsure SaveAs a different file-name to preserve the deleted sheets in original file.")

End Sub

'Follwoing unhides all (hidden) rows in current sheet.

Sub UnhideRows()

  'use following to disable the presentation mode / full-screen:

    ActiveWindow.DisplayGridlines = True

    ActiveWindow.DisplayHeadings = True

    Application.DisplayFormulaBar = True

    Application.DisplayFullScreen = False

    'CommandBars.ExecuteMso "HideRibbon"    'use DisplayFullScreen instead.

    Rows("1:" & Cells.Rows.count).EntireRow.Hidden = False

'    Call ConfirmRun("UnhideRows")

'    Dim currRow As Long

'    currRow = ActiveCell.row

'    Rows("1:" & ActiveSheet.UsedRange.Rows.count).EntireRow.Hidden = False

'    Rows(currRow).EntireRow.Select

End Sub

'Following code moves the cursor to the last column of the current row.

Sub JumpToLastColumn()

    Dim didSelect As Boolean: x = False

    On Error Resume Next

    'Cells(ActiveCell.Row, Columns.count).End(xlToLeft).Offset(0, -1).Select

    didSelect = Cells(ActiveCell.Row, Columns.count).End(xlToLeft).Select

    Debug.Print (x)

    On Error GoTo 0

    If didSelect = False Then

        MsgBox "Worksheet is empty."

    End If

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

'Sets Font:Calibri size:10 for whole (immediate) table:

Sub SetFontCalibri10()

    ActiveSheet.UsedRange.Select

    Selection.Font.name = "Calibri"

    Selection.Font.Size = 10

    'Selection.HorizontalAlignment = xlLeft

    'Range("A1").Select

    Selection(1).Select

End Sub

'Paste from clipboard then call FormatEdTableWithHeader() sub to format table (used for DU-Output):

Sub PasteAndFormatTable()

    'Paste from Clipboard:

    Range("A1").Select

    ActiveSheet.Paste

    Call FormatEdTableWithHeader

    'Copy to Clipboard:

    ActiveSheet.UsedRange.Select

    Selection.Copy

End Sub

'Splits text-to-columns then calls FormatEdTableWithHeader() sub to format table (used for DU-Output):

Sub SplitColsAndFormat()

    'Sheets("DU_Check_Automation").Select

    Range("A1").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _

        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _

        Semicolon:=False, Comma:=False, Space:=False, Other:=False, TrailingMinusNumbers:=True

         ', FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))

    Call FormatEdTableWithHeader

    Columns("C").HorizontalAlignment = xlCenter

End Sub

'Following code formats current table, follwoing elements are formatted:

'Borders, FontStyle, FontWeight, Alignment, it also Freezes top row / top-pane & sets margins.

Sub FormatEdTableWithHeader()

    'Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    'Dim LastCol As Integer: LastCol = Cells(1, Columns.count).End(xlToLeft).Column

    Dim validDate As Boolean

    Dim lastCol As Integer: lastCol = GetLastCol(ActiveSheet)

    'Dim lastRow As Double: lastRow = Cells(Rows.count, 1).End(xlUp).row

    'Dim rng As Range: Set rng = Range(Cells(1, 1), Cells(lastRow, lastCol))

    'Dim rng As Range: Set rng = Range(ActiveSheet.UsedRange.Cells(1, 1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell))

    Dim rng As Range: Set rng = ActiveSheet.UsedRange

    'Call CaptureAndResumeSheetView 'Note: if ScreenUpdating is turned off at the begining of your code, then you may not need to use this sub.

'    Debug.Print sheetIdx

'    Debug.Print cellAddr

'    Debug.Print scrollRows

'    Debug.Print scrollCol

    Call DeleteEmptyRows

    Cells.Replace What:="NULL", Replacement:="", LookAt:=xlWhole, MatchCase:=False 'replacing NULLs.

   'Freezing top row - this MUST be done BEFORE ScreenUpdating is switched off, otherwise ActiveCell gets frozen.

    Rows("2:2").Select

    ActiveWindow.FreezePanes = True

    Application.ScreenUpdating = False

    'Background Colour of Header/1st Row:

    'Range(Cells(1, 1), Cells(1, lastCol)).Interior.ColorIndex = 19

    Range(Cells(1, 1), Cells(1, lastCol)).Interior.Color = RGB(234, 255, 245)

    ActiveSheet.UsedRange.WrapText = False

    ActiveSheet.UsedRange.MergeCells = False

   'Border & FontStyle:

    'With ActiveSheet.UsedRange

    With rng

        .Font.name = "Calibri"

        .Font.Size = 10.5

        .Borders.LineStyle = xlContinuous

        .EntireRow.AutoFit

    End With

    

   'FontWeight & Alignment:

    With Rows("1:1")

        .Font.Bold = True

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlBottom

        '.WrapText = True

    End With

   

   'Set margins: Uncomment following if paper-printing is needed:

'    With ActiveSheet.PageSetup

'        .LeftMargin = Application.InchesToPoints(0.25)

'        .RightMargin = Application.InchesToPoints(0.25)

'        .TopMargin = Application.InchesToPoints(0.65)

'        .BottomMargin = Application.InchesToPoints(0.65)

'    End With

    'MsgBox "ResumeSheetView"

    'ResumeSheetView:

    'Call ColorShadeAlternateRows(rng) 'colour shades alternate rows

    'Resuming the initial view of sheet:

'    Sheets(sheetIdx).Select

'    Range(cellAddr).Select

'    ActiveWindow.ScrollRow = scrollRows

'    ActiveWindow.ScrollColumn = scrollCol

    

    'Cells.EntireColumn.AutoFit

    

     'Formatting Date columns e.g. to "dd/mm/yyyy" OR "dd/mm/yyyy hh:mm:ss":

    On Error Resume Next

    Err.Clear

    For c = 1 To Cells(1, Columns.count).End(xlToLeft).Column

        validDate = False

        'If InStr(1, CStr(Cells(1, c)), "date", vbTextCompare) Then

        '    Columns(c).NumberFormat = "dd/mm/yyyy"

        'End If

        

            tVal = CDate(Cells(2, c))  'tVal = CDate(44294.453605787)

            validDate = IsDate(tVal)

            If (Err.Number <> 0 Or Len(Trim(Cells(2, c))) = 0) Then

                Err.Clear

                GoTo NextCol

            End If

            If (validDate) Then

                'If (Year(tVal) < 1936 Or Year(tVal) > 2036) Then

                If (Year(tVal) < 2019 Or Year(tVal) > 2030) Then

                    validDate = False

                End If

            End If

            'Debug.Print validDate

            'Debug.Print tVal

            'Debug.Print CDbl(tVal)

            'If Fix(tVal) = tVal Then

            '    Debug.Print "No decimal places"

            'Else

            '     Debug.Print "Yes has decimal places"

            'End If

    'End

        If (validDate) Then

            If Fix(tVal) = tVal Then 'No decimal places

                Columns(c).NumberFormat = "dd/mm/yyyy"

            Else  'has decimal places

                'Checking for Milliseconds:  TODO

                'Cells(2, c).NumberFormat = "dd/mm/yyyy hh:mm:ss.000"

                'Debug.Print Right(CStr(Cells(2, c)), 3)  'doesn't work excel trims the ms

                Columns(c).NumberFormat = "dd/mm/yyyy hh:mm:ss"         'without ms

                'Columns(c).NumberFormat = "dd/mm/yyyy hh:mm:ss.000"    'with ms

            End If

            're.Pattern = "\d{1,2}[\/-]\d{1,2}[\/-]\d{1,4}"                            'to match: "07/06/2022"

            'If re.Test(tVal) Then

            '    Columns(c).NumberFormat = "dd/mm/yyyy"

            'End If

            're.Pattern = "\d{1,2}[\/-]\d{1,2}[\/-]\d{1,4}[ ]\d{1,2}:\d{1,2}:\d{1,2}"  'to match: "07/06/2022  09:23:26"

            'If re.Test(tVal) Then

            '    Columns(c).NumberFormat = "dd/mm/yyyy hh:mm:ss"

            'End If

        End If

NextCol:

    Next c

    On Error GoTo 0

   

    'Formatting columns e.g. price to Currency:

    For c = 1 To Cells(1, Columns.count).End(xlToLeft).Column

        'If IsNumeric(Cells(2, c)) Then

        If InStr(1, CStr(Cells(1, c)), "amount", vbTextCompare) Or InStr(1, CStr(Cells(1, c)), "price", vbTextCompare) Then

            'Columns(c).Style = "Currency"

            Columns(c).NumberFormat = "£###,###,###,##0.00"

        End If

        If InStr(1, CStr(Cells(1, c)), "tel", vbTextCompare) _

          Or InStr(1, CStr(Cells(1, c)), "phone", vbTextCompare) _

          Or InStr(1, CStr(Cells(1, c)), "fax", vbTextCompare) _

          Or InStr(1, CStr(Cells(1, c)), "isbn", vbTextCompare) Then

            Columns(c).HorizontalAlignment = xlRight

            Cells(1, c).HorizontalAlignment = xlCenter

        End If

    Next c

    Call MaxColumnWide60

    'ActiveSheet.UsedRange.AutoFilter 'turn on the AutoFilter

    'ActiveSheet.Cells.Find What:="", SearchDirection:=xlNext, Lookat:=xlPart

    'Cells.EntireColumn.AutoFit    'AutoFit column width

    Application.ScreenUpdating = True

End Sub

'Following removes/reverses all formatting done by Sub FormatEdTableWithHeader()

Sub UnformatData()

    Cells.Select

    ActiveWindow.FreezePanes = False

    With Selection.Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    Cells.FormatConditions.Delete

    Selection.ColumnWidth = 8.43

    Selection.Font.Size = 11

    'removing border lines:

    With Selection

        .Borders(xlDiagonalDown).LineStyle = xlNone

        .Borders(xlDiagonalUp).LineStyle = xlNone

        .Borders(xlEdgeLeft).LineStyle = xlNone

        .Borders(xlEdgeTop).LineStyle = xlNone

        .Borders(xlEdgeBottom).LineStyle = xlNone

        .Borders(xlEdgeRight).LineStyle = xlNone

        .Borders(xlInsideVertical).LineStyle = xlNone

        .Borders(xlInsideHorizontal).LineStyle = xlNone

'        .WrapText = False

'        .MergeCells = False

    End With

    Range("A1").Select

End Sub

'Following script ensures to keep the aborted rows only (and deletes other error-status such as OK/Completed etc.)

'it also formats the aborted rows.

Sub FormatAbortedRows()

    Cells.Replace What:="=-1=RequestCompleted", Replacement:="1=RequestCompleted", LookAt:=xlWhole, _

        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

    

    'Selection.AutoFilter  'AutoFilter to hide "Aborted" rows (to preserve them)

    'Improvements: now finds 'Error' (which is then used for Field:=# below) and finds active/used range for autofilter:

    

    colNumDur = Application.Match("Duration", ActiveSheet.Rows(1), 0)

    Columns(colNumDur).NumberFormat = "hh:mm:ss;@"

    

    colNumErr = Application.Match("Error", ActiveSheet.Rows(1), 0)

    ActiveSheet.UsedRange.AutoFilter Field:=colNumErr, Criteria1:=Array("0=OK", "1=Error", "1=RequestCompleted"), Operator:=xlFilterValues

    Rowz = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1

    If (Rowz > 0) Then

        Range("A2").Select  'exclude the header-row

        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select 'Ctrl+End'

        Selection.SpecialCells(xlCellTypeVisible).Select             'Alt+; to select only visible rows'

        Selection.EntireRow.Delete

    End If

    Selection.AutoFilter

    

    Call FormatEdTableWithHeader

    Range("A1").Select

End Sub

'Sets max column-wide to 60, checks ALL columns in sheet:

Sub MaxColumnWide60()

    Cells.Columns.AutoFit  'Autofit all columns.

    'Enforce max column-wide to 60:

    For c = 1 To Cells(1, Columns.count).End(xlToLeft).Column

        If Columns(c).ColumnWidth > 60 Then

            Columns(c).ColumnWidth = 60

        End If

    Next c

End Sub

'DATE HANDLING:

'Following converts / attempts to parse text (in selected cells) into dates.

'Beware: the date-value (converted from text) is overwritten to the containing cell.

'Sub ConvertTextToDates()

Sub ParseTextToDates()

    If IsEmpty(ActiveCell) Then

        MsgBox "Empty Cell !" & vbNewLine & vbNewLine & "Cannot convert value into date type as no value found in the selected cell."

        End

    End If

    Dim r As Range

    For Each r In Selection

        r.Value = CDate(r.text)

    Next r

End Sub

Sub DateFormattingForTime()

    MsgBox Format(Date, "dd-MM-yyyy_hhmmss")  'Date returns: no-time no-time no-time no-time ye ye ye ye

    MsgBox Format(Now, "MM/dd/yyyy h:mm:ss tt") 'Now returns: both Date & Time (but without Milliseconds).

End Sub

'Following checks if a date-value also contains the Time-part:

Sub CheckIfDateHasTimePart()

    On Error Resume Next

        tVal = CDate(44294.7050769444)

'        tVal = CDate(44294.453605787)

'        tVal = CDate(44294)

        'tVal = CDate(Cells(2, 1))

        validDate = IsDate(tVal)

        If (validDate) Then

            If (Not (Year(tVal) >= 1936 And Year(tVal) <= 2036)) Then  'excluding unwanted Number to Date conversions.

                validDate = False

            End If

        End If

        Debug.Print "Value passed in " & tVal

        Debug.Print "Is valid date?  " & validDate

        Debug.Print "Value as number " & CDbl(tVal)

        If Fix(tVal) = tVal Then

            Debug.Print "No decimals found, meaning it contains only Date-part."

        Else

            Debug.Print "Yes it has decimal places, meaning it contains Time-part too"

            'Checking for Milliseconds:

            'if () then

            Debug.Print "Formatted: " & Format(tVal, "dd/mm/yyyy hh:mm:ss.000")

            Debug.Print "Current Date/Time stamp with Milliseconds: " _

                        & Strings.Format(Now, "dd-MMM-yyyy HH:nn:ss") & "." _

                        & Strings.Right(Strings.Format(Timer, "#0.000"), 3)

            'Debug.Print tVal.NumberFormat = "dd/mm/yyyy hh:mm:ss.000"

            

        End If

    On Error GoTo 0

End Sub

'CLIPBOARD HANDLING:

'Following reads content from the Windows clipboard.

Sub GetValueFromClipboard()

    Dim DataObj As Object: Set DataObj = CreateObject("MSForms.DataObject")  'early binding.

    'Dim DataObj As MSForms.DataObject: Set DataObj = New MSForms.DataObject 'late binding.

    DataObj.GetFromClipboard

    strPaste = DataObj.GetText(1)

    Debug.Print strPaste

End Sub

'Following Sub captures the SheetView, by storing various screen-positions in some Module/Global-level variables,

'Usage: Call this sub at the begining of your code, then move around freely in the sheet, then at the end/bottom

'of your code use these global-variable to position your screen back to where it was (before running VBA code).

'Note: if ScreenUpdating is turned off at the begining of your code, then you may not need to use this sub.

Sub CaptureAndResumeSheetView()

    sheetIdx = ActiveSheet.Index

    cellAddr = ActiveCell.Address

    scrollRows = ActiveWindow.ScrollRow

    scrollCol = ActiveWindow.ScrollColumn

End Sub

'Following colour shades the alternate rows:

Sub ColorShadeAlternateRows(rng As Range)

    Dim lastCol As Integer

    'Set Rng = ActiveSheet.UsedRange

    'Rng.Interior.ColorIndex = xlNone

    rng.FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row()+1,2)"

    'Rng.FormatConditions(1).Interior.ColorIndex = 19

    rng.FormatConditions(1).Interior.Color = RGB(224, 235, 235)

    lastCol = Cells(1, Columns.count).End(xlToLeft).Column

    Range(Cells(1, 1), Cells(1, lastCol)).Interior.Color = RGB(236, 249, 236)

End Sub

Sub ListFiles()

    Dim MyFolder As String: MyFolder = "C:\Users\ashrivastava\Downloads\"

    Dim MyFile As String: MyFile = Dir(MyFolder & "*.xls")

    Dim a As Integer: a = 0

    Do While MyFile <> ""

        a = a + 1

        Cells(a, 1).Value = MyFile

        MyFile = Dir

    Loop

    MsgBox "Existing filenames are now listed in Column 'A', now type new filenames in Column 'B' (for each file)." & vbCrLf & _

        "Enter valid filenames, then Run Sub 'Rename_Files()' when ready."

End Sub

'Following function helps to determine if an Excel workbook exists,

'Note: An attempt to open non-existant workbook gives error "out of subscript".

Function IsWorkBookOpen(fileName As String)

    Dim ff As Long, ErrNo As Long

    On Error Resume Next

    ff = FreeFile()

    Open fileName For Input Lock Read As #ff

    Close ff

    ErrNo = Err

    On Error GoTo 0

    Select Case ErrNo

        Case 0:    IsWorkBookOpen = False

        Case 70:   IsWorkBookOpen = True

        Case Else: Error ErrNo

    End Select

End Function

'''usage:

'    Dim fName As String: fName = "C:\SPG\process.xlsm"

'    Dim wbk, currBook As Workbook: Set currBook = ActiveWorkbook

'    If Not IsWorkBookOpen(fName) Then

'        Set wbk = Workbooks.Open(FileName:=fName)

'    End If

'    'Debug.Print VarType(wbk) '9 = object

'Following function checks and returns true if passed worksheet-name exists.

'Usage:

'    If Not SheetExists("SheetName") Then

'        Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = "SheetName"

'    End If

  ' OR

'    If SheetExists("sName") Then MsgBox ("YES, this sheet exists.")

'    If Not SheetExists("sName") Then MsgBox ("NO, this sheet does NOT exist.")

Function SheetExists(n As String) As Boolean

  SheetExists = False

  For Each ws In Worksheets

    If n = ws.name Then

      SheetExists = True

      Exit Function

    End If

  Next ws

End Function

'Following code checks if workbook has VBProject, if yes saves files as .xlsm otherwise saves as .xlsx.

Sub BulkConvertionFromXlsIntoXlsmOrXlsx()

    Call ConfirmRun("BulkConvertionFromXlsIntoXlsmOrXlsx")

    Dim strPath As String: strPath = "C:\Users\ashrivastava\Downloads\"     ' Path must end in trailing backslash

    Dim strFile As String: strFile = Dir(strPath & "*.xls")

    Dim wbk As Workbook

    Debug.Print strFile

    ScreenUpdating = False

    Do While strFile <> ""

        If Right(strFile, 3) = "xls" Then

            Set wbk = Workbooks.Open(fileName:=strPath & strFile)

            Debug.Print VarType(wbk) '9 = object

            If wbk.HasVBProject Then

              wbk.SaveAs fileName:=strPath & strFile & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled

            Else

               wbk.SaveAs fileName:=strPath & strFile & "x", FileFormat:=xlOpenXMLWorkbook

            End If

            wbk.Close SaveChanges:=False

        End If

        strFile = Dir

    Loop

    ScreenUpdating = True

End Sub

'Following code saves the current worksheet as CSV file with same name as current sheet-name in the current folder.

Sub ExportAsTxtTabDelimited()

 Dim wBookPath As String

 If Len(ActiveWorkbook.Path) <= 0 Or ActiveWorkbook.name Like "book*" Then

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

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

 Else

    wBookPath = ActiveWorkbook.Path

 End If

 If ActiveSheet.name Like "Sheet*" Then

     wBookName = "List_" & Format(Now, "dd-MM-yyyy_hhmmss") & ".txt"

 Else

     wBookName = ActiveSheet.name

 End If

 'ChDir "\\slgpipav01\SGPData\Data-Management\Data-Manager"

 ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName & ".txt", FileFormat:=xlText, CreateBackup:=False

 MsgBox "Sheet exported as: """ & wBookName & """" & vbNewLine & vbNewLine & "Saved under: " & wBookPath

End Sub

'Following code saves the current worksheet as CSV file with same name as current sheet-name in the current folder.

Sub ExportAsCSV()

 Dim wBookPath As String

 If Len(ActiveWorkbook.Path) <= 0 Or ActiveWorkbook.name Like "book*" Then

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

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

 Else

    wBookPath = ActiveWorkbook.Path

 End If

 If ActiveSheet.name Like "Sheet*" Then

     wBookName = "List_" & Format(Now, "dd-MM-yyyy_hhmmss") & " (for Communigator).csv"

 Else

     wBookName = ActiveSheet.name

 End If

'    wBookPath = ActiveWorkbook.Path 'must be assigned BEFORE the ActiveSheet.Copy command

     ActiveSheet.Copy

     'Call DeleteUnnecessaryCols

     'wBookName = "CK remaining members 241116 ()"

     ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlCSV, CreateBackup:=False

     ActiveWorkbook.Close False

     ThisWorkbook.Activate

     MsgBox "Sheet exported as: """ & wBookName & """" & vbNewLine & vbNewLine & "Saved under: " & wBookPath

End Sub

'Following code saves the current worksheet as CSV file with same name as current sheet-name in the current folder.

Sub ExportAsCSV_Old() '''''''TODO

 Dim fileName As String: fileName = IIf(IsEmpty(ActiveWorkbook.name), ActiveSheet.name, ActiveWorkbook.name)

 If Len(fileName) > 0 Then

    fileName = Left(fileName, InStrRev(fileName, ".") - 1) 'use of InStrRev() is better than chopping fixed length using Len() e.g. Left(fileName, Len(fileName) - 4)

 End If

 On Error GoTo ErrSave

 'ActiveWorkbook.SaveAs fileName:=ActiveWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV, CreateBackup:=False

 ActiveWorkbook.SaveAs fileName:=ActiveWorkbook.Path & "\" & ActiveSheet.name & ".csv", FileFormat:=xlCSV, CreateBackup:=False

ErrSave:

    bFileSaveAs = Application.GetSaveAsFilename(InitialFileName:=fileName, fileFilter:="Excel Files (*.csv), *.csv")

    'bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show  'Dialogs() function gives less options/arguments in comparison to GetSaveAsFilename()

    If bFileSaveAs = False Then MsgBox "You cancelled, file didn't save.", vbCritical

End Sub

'Following code saves the current workbook as .XLSX file with same name as current sheet-name in the "C:\temp" or current folder:

Sub SaveAsXlsx()

    Dim wBookPath As String

    If Len(ActiveWorkbook.Path) <= 0 Or ActiveWorkbook.name Like "book*" Then

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

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

    Else

       wBookPath = ActiveWorkbook.Path

    End If

    If ActiveSheet.name Like "Sheet*" Then

        wBookName = "List_" & Format(Now, "dd-MM-yyyy_hhmmss") & " (for review).xlsx"

    Else

        wBookName = ActiveSheet.name

    End If

 

    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(wBookPath) Then

        If MsgBox("File already exists in this location.  Do you want to replace it?", vbYesNo) = vbYes Then

            ActiveWorkbook.SaveAs wBookPath, 52

            'ActiveWorkbook.SaveAs fileName:="\\slgpipav01\Homedrive\eddie.shrivastava\Documents\test3.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

            ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

        End If

    Else

        ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

        'ActiveWorkbook.SaveAs FilePath, 52

    End If

    Set fso = Nothing

    MsgBox "Sheet exported as: """ & wBookName & """" & vbNewLine & vbNewLine & "Saved under: " & wBookPath & "\"

End Sub

'Following code exports/saves the current worksheet as a separate .XLSX file with same name as current sheet-name in the "C:\temp" or current folder:

Sub ExportCurrentSheetAsXlsx()

    Dim wBookPath As String

    If Len(ActiveWorkbook.Path) <= 0 Or ActiveWorkbook.name Like "book*" Then

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

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

    Else

       wBookPath = ActiveWorkbook.Path

    End If

    If ActiveSheet.name Like "Sheet*" Then

        wBookName = "List_" & Format(Now, "dd-MM-yyyy_hhmmss") & " (for review).xlsx"

    Else

        wBookName = ActiveSheet.name

    End If

 

    Worksheets(ActiveSheet.name).Copy  'there is now a new active workbook (with your sheet in it) which can be saved.

    On Error GoTo ErrHandler:

    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(wBookPath) Then

        If MsgBox("File already exists in this location.  Do you want to replace it?", vbYesNo) = vbYes Then

            ActiveWorkbook.SaveAs wBookPath, 52

            'ActiveWorkbook.SaveAs fileName:="\\slgpipav01\Homedrive\eddie.shrivastava\Documents\test3.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

            ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

        End If

    Else

        ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

        'ActiveWorkbook.SaveAs FilePath, 52

    End If

    Set fso = Nothing

    MsgBox "Sheet exported as: """ & wBookName & """" & vbNewLine & vbNewLine & "Saved under: " & wBookPath & "\"

    

ErrHandler:

    If Err.Number = 1004 Then  'error# 11 = divide by zero

        Debug.Print "Err#1004: A file with same name currently open, therefore cannot be overwritten.  Please close that file and try again."

        Debug.Print Err.Number

        Debug.Print Err.Description

        MsgBox "Err#1004: A file with same name currently open, therefore cannot be overwritten.  Please close that file and try again.", vbCritical, "Unexpected error"

    Else

        MsgBox "Unexpected error occurred, see error-details in Immediate windowpane. Please contact Eddie Shrivastava to resolve.", vbCritical, "Unexpected error"

        Debug.Print Err.Number

        Debug.Print Err.Description

    End If

    On Error GoTo 0

End Sub

'Following sub exports each sheet of the ActiveWorkbook as a separate .xlsx file.

'It is a very useful generic utility:

Sub SplitWorkbookExportSheetsAsXlsx()

    Dim FileExtStr As String

    Dim FileFormatNum As Long

    Dim xWs As Worksheet

    Dim xWb As Workbook

    Dim FolderName As String

    Application.ScreenUpdating = False

    Set xWb = Application.ActiveWorkbook

    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")

    'FolderName = xWb.Path & "\" & xWb.Name & " " & DateString

    FolderName = xWb.Path & "\" & "CK Customer Usage Files " & DateString

    MkDir FolderName

    For Each xWs In xWb.Worksheets

        If xWs.name Like "Member Analytics*" Then

            GoTo NextIteration

        End If

        xWs.Copy

        If Val(Application.Version) < 12 Then

            FileExtStr = ".xls": FileFormatNum = -4143

        Else

            Select Case xWb.FileFormat

                Case 51:

                    FileExtStr = ".xlsx": FileFormatNum = 51

                Case 52:

                    If Application.ActiveWorkbook.HasVBProject Then

                        FileExtStr = ".xlsm": FileFormatNum = 52

                    Else

                        FileExtStr = ".xlsx": FileFormatNum = 51

                    End If

                Case 56:

                    FileExtStr = ".xls": FileFormatNum = 56

                Case Else:

                    FileExtStr = ".xlsb": FileFormatNum = 50

            End Select

        End If

        xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).name & FileExtStr

        Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum

        Application.ActiveWorkbook.Close False

NextIteration:

    Next

    MsgBox "Files exported to the following folder: " & vbNewLine & vbNewLine & FolderName

    Application.ScreenUpdating = True

End Sub

'Vba Code Eliminate "Illegal Characters" from a filename

Function strLegalFileName(strFileNameIn As String) As String

    Dim i As Integer

    Const strIllegals = "\/|?*<>"":"

    strLegalFileName = strFileNameIn

    For i = 1 To Len(strIllegals)

        strLegalFileName = Replace(strLegalFileName, Mid$(strIllegals, i, 1), "_")

    Next i

End Function

'Following compares Column A against B & highlights values not found in the other Column

'Note: alternatively you can use Match() WS function manually, e.g. in C1: ="A" & MATCH(B1, $A$1:$A$41, 0)

Sub CompareAandBColumnsHighlightNoMatches()

    Dim lastRowA, lastRowB, r As Long

    Dim rng As Range

    lastRowA = Cells(Rows.count, 1).End(xlUp).Row

    lastRowB = Cells(Rows.count, 2).End(xlUp).Row

    Dim hasDiff As Boolean: hasDiff = False

  'checking each value in B column agains full range of column A:

    Set rng = Range("A1:A" & lastRowA)

    For r = 1 To lastRowB

        If IsError(Application.Match(Cells(r, "B"), rng, 0)) Then

            'Cells(r, "B").Interior.Color = RGB(255, 255, 0)

            Cells(r, "B").Interior.ColorIndex = 22

            Debug.Print Cells(r, "B")

            hasDiff = True

        End If

    Next r

  'checking each value in column A agains full range of column B:

    Set rng = Range("B2:B" & lastRowB)

    For r = 2 To lastRowA

        If IsError(Application.Match(Cells(r, "A"), rng, 0)) Then

            Cells(r, "A").Interior.ColorIndex = 39

            Debug.Print Cells(r, "A")

            hasDiff = True

        End If

    Next r

    If hasDiff Then

        MsgBox "Differences in Columns A vs B highlighted.", vbInformation

    Else

        MsgBox "No difference found in Columns A vs B.", vbInformation

    End If

End Sub

'Following compares selected columns & highlights values not found in the other Column

'Note: alternatively you can use Match() WS function manually, e.g. in C1: ="A" & MATCH(B1, $A$1:$A$41, 0)

Sub CompareSelectedColumnsAndHighlightNoMatches()

    Dim lastRowA, lastRowB, r As Long

    

    'Get 1st column from user:

    Dim col1 As String: col1 = GetTargetColumn()

    If col1 = "" Then

        col1 = "A"

    End If

    

    'Get 2nd column from user:

    Dim col2 As String: col2 = GetTargetColumn()

    If col2 = "" Then

        col2 = "B"

    End If

    

    Dim rng As Range

    lastRowA = Cells(Rows.count, col1).End(xlUp).Row

    lastRowB = Cells(Rows.count, col2).End(xlUp).Row

    

    Dim hasDiff As Boolean: hasDiff = False

  'checking each value in B column agains full range of column A:

    Set rng = Range(col1 & "1:" & col1 & lastRowA)

    For r = 1 To lastRowB

        If IsError(Application.Match(Cells(r, col2), rng, 0)) Then

            'Cells(r, col2).Interior.Color = RGB(255, 255, 0)

            Cells(r, col2).Interior.ColorIndex = 22

            'Debug.Print Cells(r, col2)

            hasDiff = True

        End If

    Next r

  'checking each value in column A agains full range of column B:

    Set rng = Range(col2 & "1:" & col2 & lastRowB)

    For r = 1 To lastRowA

        If IsError(Application.Match(Cells(r, col1), rng, 0)) Then

            'Cells(r, col1).Interior.Color = RGB(255, 255, 0)

            Cells(r, col1).Interior.ColorIndex = 39

            'Debug.Print Cells(r, col1)

            hasDiff = True

        End If

    Next r

    If hasDiff Then

        MsgBox "Differences in selected columns have been highlighted.", vbInformation

    Else

        MsgBox "No difference found in selected columns.", vbInformation

    End If

End Sub

'Following code removes duplicate Interests/Keywords, basically it inserts a new column on the right of "sourceCol"

'then copies the deduped values (of "sourceCol") into the newly inserted "targetCol"

Sub DedupeKeywordsAndCopyInNewColumn()

    Application.ScreenUpdating = False

    Dim lastRow As Long, r As Long

    Dim sourceCol As Integer: sourceCol = 4  'source column containing Interests.

    Columns(sourceCol).Offset(0, 1).EntireColumn.Insert

    Dim targetCol As Integer: targetCol = sourceCol + 1  'Target column will contain unique Interests.

    Dim matched As Boolean

    Dim idx As Integer

    Dim kw() As String

    Dim dedupedKw() As String

    lastRow = Cells(Rows.count, sourceCol).End(xlUp).Row

    For r = 1 To lastRow

        If Not IsEmpty(Cells(r, sourceCol)) Then

            kw() = Split(Cells(r, sourceCol), "#")

            'Deduping process: 1) write 1st item regardless as deduped-output

            '2) (starting from 2nd item) match/check for equality only to the left item,

            '3) if matched skip it & immediately exit to outer loop, if unmatched write as deduped-output.

            ReDim dedupedKw(1)

            dedupedKw(0) = kw(0) '1) writing 1st item regardless as deduped-output

            idx = 1

            For i = 1 To UBound(kw)

                matched = False

                For j = i - 1 To 0 Step -1

                    If kw(i) = kw(j) Then

                        matched = True

                        Exit For

                    End If

                Next j

                If matched = False Then

                    ReDim Preserve dedupedKw(idx + 1)

                    dedupedKw(idx) = kw(i)

                    idx = idx + 1

                End If

            Next i

            Cells(r, targetCol) = Left(Join(dedupedKw, "#"), Len(Join(dedupedKw, "#")) - Len("#")) 'to omit the last delimiter: Left( Join(arr,"delimiter"), Len(Join(arr,"delimiter")) - Len(delimiter) )

            'Cells(r, targetCol) = Join(dedupedKw, "#")

        End If

    Next r

    Application.ScreenUpdating = True

End Sub

'This sub works in cunjunction with the =SubTotal(--(A1&B1 = $A$1:$A$20&$B$1:$B$20)) function (in col 'H'), which

'compares entire row (colRowSubTotal) for duplication, it produces value>1 if another identical row is found in the dataset.

'Make sure that column 'A' is sorted. To keep latest record, sort the dataset in descending-time/chronological order.

'This sub then deletes duplicates rows (from bottom), it also highlights the rows that have same value in col 'E'.

Sub DeDupContactsBeforeImport()

    Application.ScreenUpdating = False

    Dim recForReview, recDeleted As Integer: recForReview = 0: recDeleted = 0

    Dim lastRow As Long, r As Long

    Dim tVal, colContainingEmail, colRowSubTotal As String

    colContainingEmail = "E"    'this is the column containing emails.

    colRowSubTotal = "H"       'this is the column containing =SubTotal() furmula.

    lastRow = Cells(Rows.count, colRowSubTotal).End(xlUp).Row

    For r = lastRow To 2 Step -1

        If Cells(r, colContainingEmail) = Cells(r - 1, colContainingEmail) And Cells(r, colRowSubTotal) > 1 Then

            Rows(r).EntireRow.Delete

            recDeleted = recDeleted + 1

            GoTo NextIteration

        ElseIf Cells(r, colContainingEmail) = Cells(r - 1, colContainingEmail) And Cells(r, colRowSubTotal) = 1 Then

            recForReview = recForReview + 1

            Rows(r).Interior.ColorIndex = 3

        End If

NextIteration:

    Next r

    Application.ScreenUpdating = True

    MsgBox "All done. " & vbNewLine & recForReview & " records for review." & vbNewLine & recDeleted & " records deleted."

End Sub

'Following code filters and only shows rows containing selected OCI

Sub FilterAndShowRowsContainingSelectedText__SingleWordSearch_Ver1()

    'Call ConfirmRun("FilterAndShowRowsContainingSelectedText")  'no need to confirm as prompts another pop up.

    'ScreenUpdating = False

    Dim lastRow, r As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim aCell As Range

    Dim s, col As String

    Dim name, showHide As Variant

'    If ActiveSheet.name <> "Sheet1" And ActiveSheet.name <> "IncompleteSheet" Then

'        MsgBox "Cannot run code from within current worksheet!!! Select correct worksheet."

'        End

'    End If

    name = InputBox("Enter text to filter rows (hide rows that do not contain your text)", "Filter Rows")

    If name = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf name = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        End

    End If

    showHide = MsgBox("Click 'Yes' to SHOW rows containing your text, click 'No' to HIDE rows containing your text", vbYesNoCancel + vbQuestion, "Show or Hide rows")

    If showHide = vbCancel Then

        End

    End If

    If name <> "" Then

        'Set aCell = Range("F2:K200").Find(What:=name, LookIn:=xlValues, MatchCase:=False, Lookat:=xlPart, SearchFormat:=False, SearchOrder:=xlByRows or xlByColumns)

        Set aCell = ActiveSheet.UsedRange.Find(name)

        If Not aCell Is Nothing Then

            For r = lastRow To 1 Step -1

                s = ""

                For i = 1 To Cells(r, Columns.count).End(xlToLeft).Column

                    s = s & Cells(r, i)

                Next i

                If showHide = vbYes Then

                    If InStr(1, s, name, vbTextCompare) = 0 Then  'hide if NOT found

                        Rows(r).Hidden = True

                    End If

                ElseIf showHide = vbNo Then

                    If InStr(1, s, name, vbTextCompare) > 0 Then   'hide if Found

                        Rows(r).Hidden = True

                    End If

                End If

            Next r

        Else

            MsgBox """" & name & """" & " not found."

        End If

    End If

    'ScreenUpdating = True

End Sub

'Following code filters and either shows or hides rows containing text entered by user,

' also only applies filter to the row numbers(Row-Range) that user has entered.

'DESCRIPTION:

'  This script provides customised advanced filter like functionality to allow search of non-consecutive words

'  in a row or cell. It also provide selectable range options as both multiple column-range as well as multiple

'  row-range feature on which custom filter can be applied.

'Sub FilterByWords-List()

Sub FilterAndShowRowsContainingSelectedText()

    'Call ConfirmRun("FilterAndShowRowsContainingSelectedText")  'no need to confirm as prompts another pop up.

    Dim lastRow, r As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim aCell, rngCols, rng As Range

    Dim elementFound, validRng As Boolean: validRng = True

    Dim s, col As String

    Dim name, showHide, ansRng, arr, arrRng, arrRows2Unhide As Variant

    Dim i, j As Integer

    Dim sngStart, sngEnd, sngElapsed As Single

    Dim strCol, rows2Unhide As String

    name = Application.InputBox("Enter words (separated by comma)" & vbNewLine & vbNewLine & "This will filter the rows - depending on whether you choose to hide or display the rows containing your word(s).", "Enter words to filter rows")

    If name = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf name = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        End

    End If

    'checking existance of search terms again within the ENTIRE-Sheet:

    Dim notFoundEndSub As Boolean: notFoundEndSub = True

    

    If name <> "" Then

        arr = Split(name, ",")

        'getting rid of whitespaces:

        For i = 0 To UBound(arr)

            arr(i) = Trim(arr(i))

            Set aCell = ActiveSheet.UsedRange.Find(What:=arr(i), LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart, SearchFormat:=False)

            If Not aCell Is Nothing Then

                notFoundEndSub = False

                Exit For

            End If

        Next i '      MsgBox Join(arr, "_")

    End If

    If notFoundEndSub Then

        MsgBox "Word(s) don't exist in this sheet." & vbNewLine & vbNewLine & " You entered:  """ & name & """"

        'MsgBox "Word(s) don't exist in this sheet (in a single row or a cell)." & vbNewLine & vbNewLine & " You entered:  """ & name & """"

        End

    End If

  'Getting Row-Range:

    validRng = True

    ansRng = InputBox("Enter row number(s) / row-range separated by hyphen (e.g. 3-9) to limit the range on which filter is to be applied." & vbNewLine & vbNewLine & "If left blank, filter will be applied to all rows.", "Enter Row-Range")

'    If ansRng = "" Then     'user cancelled or clicked OK without inputing anything, hence returned empty-string "".

    If ansRng <> "" Then     'user neither cancelled nor entered empty-string (both checked as call without "Application.")

        If (InStr(ansRng, "-") <= 0) Then

            ansRng = "1-" & ansRng  'Include header row in search.

            'ansRng = "2-" & ansRng  'Excludes header row in search.

        End If

        arrRng = Split(ansRng, "-")

        'RowRngValidation: Validating row numbers and getting rid of whitespaces:

        For i = 0 To UBound(arrRng)

            arrRng(i) = Trim(arrRng(i))

            If Not IsNumeric(arrRng(i)) Or arrRng(i) <= 0 Or arrRng(i) > 1048576 Then

                MsgBox "Incorrect range format, filter will be applied to all rows" & vbNewLine & vbNewLine & "(Note: range must be entered as numbers seperated by hyphen (e.g. 2-7 for 2nd-to-7th rows)" & vbNewLine & vbNewLine & "You entered:  " & ansRng

                validRng = False

                Exit For

            End If

        Next i

    Else

        validRng = False

    End If

    If validRng Then

        firstRow = Trim(arrRng(0))

        If UBound(arrRng) >= 1 Then

            If arrRng(1) <> "" Then

                lastRow = arrRng(1)

            End If

        Else

            lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row

        End If

    Else

        firstRow = ActiveSheet.UsedRange.Row  ' + 1

        lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row  'last used row

    End If

    'checking existance of search terms again within the given ROW-Range:

    notFoundEndSub = True

    For i = 0 To UBound(arr)

        arr(i) = Trim(arr(i))

        'Set aCell = ActiveSheet.UsedRange.Find(arr(i))

        Set aCell = Rows(firstRow & ":" & lastRow).Find(What:=arr(i), LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByRows)

        If Not aCell Is Nothing Then

            notFoundEndSub = False

            Exit For

        End If

    Next i

    If notFoundEndSub Then

            MsgBox "Your word(s) don't exist in the row-range you typed." & vbNewLine & vbNewLine & "Search-term(s)/Word(s) you entered:  """ & name & """" & vbNewLine & vbNewLine & "Row-range you entered:  """ & ansRng & """"

            'MsgBox "Your word(s) don't exist in the row-range you typed (within a single row or in a cell)." & vbNewLine & vbNewLine & "Search-term(s)/Word(s) you entered:  """ & name & """" & vbNewLine & vbNewLine & "Row-range you entered:  """ & ansRng & """"

            End

    End If

  'Getting Column-Range:

    validRng = True

    'ansRng = InputBox("Enter column letter(s) separated by comma(e.g. A, C, F for individual columns) OR column-range separated by hyphen (e.g. A-F from A through F columns) to limit the range on which filter is to be applied." & vbNewLine & vbNewLine & "If left blank, filter will be applied to all columns.", "Enter Column-Range")

    ansRng = Trim(InputBox("Enter column letter(s) separated by comma(e.g. A, C, F for individual columns) to limit the range on which filter is to be applied." & vbNewLine & vbNewLine & "If left blank, filter will be applied to all columns.", "Enter Column-Range"))

'    If ansRng = "" Then     'user cancelled or clicked OK without inputing anything, hence returned empty-string "".

    If ansRng <> "" Then     'user entered some text, i.e. neither cancelled nor entered empty-string (both are checked as call without "Application.")

    ''''''''''is it range separated by "-" or individual multiple columns seperated by ","

'        If InStr(ansRng, "-", vbTextCompare) Then ElseIf InStr(ansRng, ",", vbTextCompare) Then  ...  End If

        arrRng = Split(ansRng, ",")

        'RowRngValidation: Validating row numbers and getting rid of whitespaces:

        For i = 0 To UBound(arrRng)

            arrRng(i) = Trim(arrRng(i))

            If Not hasAlphabets(arrRng(i) & "") Or Len(arrRng(i)) <= 0 Or Len(arrRng(i)) > 3 Then

                MsgBox "Incorrect column letters format, filter will be applied to all columns" & vbNewLine & vbNewLine & "(Note: Column range must be entered as Excel Column-Alphabets seperated by comma (e.g. A,C for 1st & 3rd Columns)" & vbNewLine & vbNewLine & "You entered  :" & ansRng

                validRng = False

                Exit For

            End If

            If i = 0 Then

                Set rngCols = Range(Cells(firstRow, arrRng(i)), Cells(lastRow, arrRng(i)))

            Else

                Set rngCols = Union(rngCols, Range(Cells(firstRow, arrRng(i)), Cells(lastRow, arrRng(i))))

            End If

        Next i

    Else

        validRng = False

    End If

    If Not validRng Then

        strCol = ""

    Else

        notFoundEndSub = True

        For i = 0 To UBound(arr)

            Set aCell = rngCols.Find(What:=arr(i), LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByColumns)

            If Not aCell Is Nothing Then

                notFoundEndSub = False

                Exit For

            End If

        Next i

        If notFoundEndSub Then

            MsgBox "Your word(s) don't exist in the column-range you typed." & vbNewLine & vbNewLine & "Word(s) you entered  : """ & name & """" & vbNewLine & vbNewLine & "Column range you entered: """ & ansRng & """"

            End

        End If

        strCol = arr(0)

    End If

'    strCol = Trim(InputBox(Prompt:="Enter the target Column-Letter (e.g. 'A' for 1st Column)." & vbNewLine & vbNewLine & "Leave blank to apply filter to all columns.", Title:="Enter Column-Range"))

    showHide = MsgBox("Click 'Yes' to SHOW the rows containing all your words, click 'No' to HIDE rows containing your words", vbYesNoCancel + vbQuestion, "Choose whether to Show or Hide rows")

    If showHide = vbCancel Then

        End

    End If

    TurnOffOtherExcelActivities (True)

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

    sngStart = Timer                               ' Get start time.

    For r = lastRow To firstRow Step -1

        'Set s = Nothing 'completely deletes of variable, instead of purging its value, hence unusable in this situation.

        s = ""

        If strCol = "" Then

            For j = 1 To Cells(r, Columns.count).End(xlToLeft).Column

                s = s & "¬" & Cells(r, j)

            Next j

        Else

        '''''' for multiple columns: loop here in each columns

            For i = 0 To UBound(arrRng)

                s = s & Cells(r, arrRng(i))

            Next i

        End If

        elementFound = False

        For i = 0 To UBound(arr)

            If InStr(1, s, arr(i), vbTextCompare) > 0 Then  'check if found

                'this "if" section filters as if search-terms have "OR" (means check for ANY(one) of the search-terms presence)

                elementFound = True

                Exit For 'enable/uncomment this for "OR" logic i.e. ANY words + disable/comment the "Exit For" in the "Else" section below + change the logics at <range>.Find above.

            Else

                'this "else" section filters as if search-terms have "AND" (means check for ALL of the search-terms presence)

                elementFound = False

                'Exit For 'enable/uncomment this for "AND" logic i.e. ALL words + disable/comment the "Exit For" in the "IF" section above + change the logics at <range>.Find above.

            End If

        Next i

        If elementFound Then  'hide if NOT found

            'Rows(r).Hidden = True

            rows2Unhide = rows2Unhide & r & ","

        End If

    Next r

    arrRows2Unhide = Split(rows2Unhide, ",")

    isFirstIteration = True

    For i = 0 To UBound(arrRows2Unhide) - 1

        x = arrRows2Unhide(i)

        If i = 0 Then

            Set rng = Range(x & ":" & x)

        Else

            Set rng = Union(rng, Range(x & ":" & x))

        End If

        'strRows2Unhide = strRows2Unhide & "Rows(""" & x & ":" & x & """),"

        'strRows2Unhide = Mid(strRows2Unhide, 1, Len(strRows2Unhide) - 1)

    Next i

    'Debug.Print rng.Address

    If showHide = vbYes Then

        Rows(firstRow & ":" & lastRow).EntireRow.Hidden = True

        rng.EntireRow.Hidden = False  'Range() method only takes upto 45 parameters, after which it throws error.

    Else

        rng.EntireRow.Hidden = True  'Range() only takes upto 45 parameters, after which it throws error.

    End If

    Rows(1).Hidden = False  'Unhide header row. Toggle this to show/hide the header row.

    aCell.Select

    TurnOffOtherExcelActivities (False)

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

    sngEnd = Timer                                 ' Get end time.

    sngElapsed = Format(sngEnd - sngStart, "Fixed") ' Elapsed time.

    MsgBox ("Custom filter applied." & vbNewLine & vbNewLine & "The code took " & sngElapsed & " seconds to run.")

End Sub

'Following code filters and either shows or hides rows containing text entered by user.

Sub FilterAndShowRowsContainingSelectedText_AppliesToEntireSheet_OLD()

    'Call ConfirmRun("FilterAndShowRowsContainingSelectedText")  'no need to confirm as prompts another pop up.

    Dim lastRow, r As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim aCell As Range

    Dim elementFound As Boolean

    Dim s, col, arr() As String

    Dim name, showHide As Variant

    Dim i, j As Integer

    Dim sngStart, sngEnd, sngElapsed As Single

'    If ActiveSheet.name <> "Sheet1" And ActiveSheet.name <> "IncompleteSheet" Then

'        MsgBox "Cannot run code from within current worksheet!!! Select correct worksheet."

'        End

'    End If

    name = InputBox("Enter words (separated by comma), this will filter the rows - letting you choose whether to hide or show rows that contain your word(s).", "Filter Rows")

    If name = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf name = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        End

    End If

    showHide = MsgBox("Click 'Yes' to SHOW the rows containing all your words, click 'No' to HIDE rows containing your words", vbYesNoCancel + vbQuestion, "Choose whether to Show or Hide rows")

    If showHide = vbCancel Then

        End

    End If

    ScreenUpdating = False

    sngStart = Timer                               ' Get start time.

    If name <> "" Then

        arr() = Split(name, ",")

        'getting rid of whitespaces:

        For i = 0 To UBound(arr)

            arr(i) = Trim(arr(i))

        Next i

'      MsgBox Join(arr, "_")

        Set aCell = ActiveSheet.UsedRange.Find(What:=arr(0), LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart, SearchFormat:=False, SearchOrder:=xlByRows)

        If Not aCell Is Nothing Then

            For r = lastRow To 2 Step -1

                s = ""

                For j = 1 To Cells(r, Columns.count).End(xlToLeft).Column

                    s = s & Cells(r, j)

                Next j

                elementFound = False

                If showHide = vbYes Then

                    For i = 0 To UBound(arr)

                        If InStr(1, s, arr(i), vbTextCompare) > 0 Then  'check if found

                            elementFound = True

                        Else

                            elementFound = False

                            Exit For  'even if one of the elements not found

                        End If

                    Next i

                    If Not elementFound Then  'hide if NOT found

                        Rows(r).Hidden = True

                    End If

                ElseIf showHide = vbNo Then

                    For i = 0 To UBound(arr)

                        If InStr(1, s, arr(i), vbTextCompare) > 0 Then  'check if found

                            elementFound = True

                        Else

                            elementFound = False

                            Exit For  'even if one of the elements not found

                        End If

                    Next i

                    If elementFound Then  'hide if found

                        Rows(r).Hidden = True

                    End If

                End If

            Next r

        Else

            MsgBox """" & name & """" & " not found."

        End If

    End If

    ScreenUpdating = True

    sngEnd = Timer                                 ' Get end time.

    sngElapsed = Format(sngEnd - sngStart, "Fixed") ' Elapsed time.

    MsgBox ("Custom filter applied." & vbNewLine & vbNewLine & "The code took " & sngElapsed & " seconds to run.")

End Sub

Sub FiterSouthEastAndLondonPostcodesOnly()

    Dim tVal, c, PostCodeColumn As String

    'PostCodeColumn = "E"       'set target COLUMN here, which contains Postcodes.

    PostCodeColumn = GetTargetColumn()

    If PostCodeColumn = "" Then

        End

    End If

    

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

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

    Dim r, lastRow As Long

  'POSTCODE PREFIXES of SOUTH EAST + LONDON + some postcodes near south east:

    'arr = Split("BN,BR,CR,CT,DA,GU,HP,KT,ME,MK,OX,PO,RG,RH,SL,SM,SO,TN,TW,UB,WD,EC,NW,SE,SW,W,WC,GL,SN,SP,BH,CO,SS,AL,LU,HA,IG,RM,EN", ",")

    'arr = Split("BN,BR,CR,CT,DA,GU,HP,KT,ME,PO,RG,RH,SL,SM,SO,TN,TW,UB,WD,EC,NW,SE,SW,W,WC,SN,SP,BH,SS,HA,IG,RM,EN", ",")

    'arr = Split("BN,BR,CR,CT,DA,GU,HP,KT,ME,PO,RG,RH,SL,SM,SO,TN,TW,SN,SP,BH", ",")

    'arr1Chars = Split("N,E,W", ",")

    r = PostCodeColumn

    For r = 2 To ActiveSheet.UsedRange.Rows.count

        'If Not ((IsInArray(Left(Cells(r, PostCodeColumn), 2), arr)) Or (IsInArray(Left(Cells(r, PostCodeColumn), 1), arr1Chars) And IsNumeric(Mid(Cells(r, PostCodeColumn), 2, 1)))) Then

        If Not (IsInArray(Left(Cells(r, PostCodeColumn), 2), arr)) Then

        'InStr(1, "Hello World", "Hello W") = 1

            Rows(r).EntireRow.Hidden = True

        End If

    Next r

End Sub

'Folloing code deletes extra whitespaces in between the words (in column 'F') leaving 1 whitespace.

Sub DeleteExtraWhitespaceBetweenWords()

    Dim lastRow, r As Long: lastRow = Cells(Rows.count, 1).End(xlUp).Row

    Dim s As String

    For r = lastRow To 1 Step -1

        s = Cells(r, "F")

        If InStr(s, "    ") <> 0 Then

            s = Replace(s, "    ", " ")

            Cells(r, "F") = s

            'Debug.Print

        End If

    Next r

End Sub

'This code deletes all empty cell in current column - collapsing the entire table into compact unstructured set of data:

Sub DeleteEmptyCellsCollapseEntireTable()

    Call ConfirmRun("DeleteEmptyCellsCollapseEntireTable")

    Dim tmpRng As Range

    On Error Resume Next

    Set tmpRng = Columns(ActiveCell.Column).SpecialCells(xlBlanks)

    If Not tmpRng Is Nothing Then

        Debug.Print WorksheetFunction.CountA(ActiveSheet.UsedRange) 'BEFORE: 'total used rows should remain same after running this sub.

        ActiveSheet.UsedRange.SpecialCells(xlBlanks).Delete Shift:=xlUp  'will delete only blank cells shifting up all cells below.

        Debug.Print WorksheetFunction.CountA(ActiveSheet.UsedRange) 'AFTER: 'total used rows should remain same after running this sub.

    Else

        MsgBox "No empty cells found."

    End If

    On Error GoTo 0

End Sub

'This code deletes all empty cell in current column - collapsing the column into compact unstructured column of data:

Sub DeleteEmptyCellsCollapseSingleColumn()

    Call ConfirmRun("DeleteEmptyCellsCollapseSingleColumn")

    Dim tmpRng As Range

    Debug.Print WorksheetFunction.CountA(Columns(ActiveCell.Column)) 'BEFORE: 'total used rows should remain same after running this sub.

    On Error Resume Next

    Set tmpRng = Columns(ActiveCell.Column).SpecialCells(xlBlanks)

    'If TypeName(tmpRng) <> "Empty" Then

    If Not tmpRng Is Nothing Then

        Columns(ActiveCell.Column).SpecialCells(xlBlanks).Delete Shift:=xlUp  'will delete only blank cells shifting up all cells below.

    Else

        MsgBox "No empty cells found."

    End If

    Debug.Print WorksheetFunction.CountA(Columns(ActiveCell.Column)) 'AFTER: 'total used rows should remain same after running this sub.

    On Error GoTo 0

End Sub

'This code moves all cells in column A - collapsing entire table into one column - this is useful to get unique values (in entire table).

'note: it one-by-one places columns below Column-A, starting with Col-B under Col-A then Col-C, then D and so on.

Sub MoveAllDataInOneColumnA()

    'Call ConfirmRun("MoveAllDataInOneColumnA")

    Dim endRow, endCol, targetRowNum As Long

    ScreenUpdating = False

    Call DeleteEmptyCellsCollapseEntireTable

    targetRowNum = Range("A" & Rows.count).End(xlUp).Row + 1

    'MsgBox targetRowNum

    endCol = ActiveSheet.UsedRange.SpecialCells(11).Column  '11 = xlCellTypeVisible

    For i = 2 To endCol

        Range(Cells(1, i), Cells(Rows.count, i).End(xlUp)).Cut Destination:=Range("A" & targetRowNum)

        targetRowNum = Range("A" & Rows.count).End(xlUp).Row + 1

'        MsgBox targetRowNum

'        End

    Next

    'endRow = .UsedRange.SpecialCells(xlCellTypeLastCell).row

    Dim lngMaxRow As Long

    lngMaxRow = Range("D" & Rows.count).End(xlUp).Row

    Set InputRange = Range("D1:D" & lngMaxRow)

    ScreenUpdating = True

    MsgBox "Done... All cells now moved to one column (column A)."

End Sub

'Following sub moves all the cell-values into Column-A row-by-row:

Sub MoveCellValuesIntoColA()

    Application.ScreenUpdating = True

    Range("A1").Select

    ActiveCell.SpecialCells(xlLastCell).Select

    ActiveCell.Offset(0, 1).End(xlUp).Select

    Call ConcatenateLeftCellsTillLastRow

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    ActiveCell.Offset(0, 1).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    ActiveCell.Offset(0, -1).Select

    Range(Selection, Cells(ActiveCell.Row, 1)).Select

    Selection.EntireColumn.Delete

    Range("A1").Select

    Application.ScreenUpdating = False

End Sub

'This code deletes all empty rows in ActiveSheet:

Sub DeleteEmptyRows()

    ScreenUpdating = False

    'endRow = ActiveSheet.UsedRange.Rows.Count

    endRow = Cells(Rows.count, 1).End(xlUp).Row

    'Debug.Print WorksheetFunction.CountA(Columns(1)) 'total used rows should remain same after running this sub.

    'Debug.Print endRow

    For i = endRow To 1 Step -1

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

            Rows(i).Delete

        End If

    Next

    ScreenUpdating = True

End Sub

'Following code deletes all empty columns in ActiveSheet (only):

Sub DeleteEmptyColumns()

'If TypeName(Selection) = "Range" Then

'    MsgBox "You selected a Range"

'Else

'    MsgBox "Woops! you selected a " & TypeName(Selection)

'End If

    ScreenUpdating = False

    lastCol = Cells(1, Columns.count).End(xlToLeft).Column 'assuming 1st row has headers.

    'lastCol = ActiveSheet.UsedRange.Columns.Count

    For i = lastCol To 1 Step -1

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

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

            Columns(i).Delete

        End If

    Next

    ScreenUpdating = True

End Sub

'Following sub moves the current row from current worksheet to another Sheet.

Sub MoveRowToAnotherSheet()

    Debug.Print ActiveWorkbook.Sheets.count

    'Dim arrSheetsInBook(ActiveWorkbook.Sheets.Count) As String 'You can't DIM an array using a variable, solution is to ReDim it.

    Dim arrSheetsInBook() As String

    ReDim arrSheetsInBook(ActiveWorkbook.Sheets.count)

'    Dim sh, ans As String

        'Destination sheet:

        

        

For Each cLoc In ws.Range("LocationList")

Next cLoc

'    Dim r As Integer

'    Dim incNo As Long 'Must be Long not Integer be able to store 8 digit Inc number, otherwise 'Overflow Runtime 6' error.

'    sh = ActiveSheet.name

'    r = ActiveCell.row

'    incNo = Cells(r, 1)

'    ans = MsgBox("Would you like to move the current row with Inc No: " & incNo & " to the ""Completed"" sheet?", vbYesNo, "Move Row!")

'    If ans = vbYes Then

'        ActiveSheet.Cells(r, "G").Interior.ColorIndex = xlNone

'        ActiveSheet.Cells(r, "G") = "Completed"

'        ActiveSheet.Cells(r, "N") = Date

'        ActiveCell.EntireRow.Cut _

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

'        MsgBox "Inc No: " & incNo & " from row number: " & r & " has been moved to ""Completed"" sheet"

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

'    End If

End Sub

Sub MoveRowFromIncompleteToCompleteSheet()

    Dim Sh, ans As String

    Dim r As Integer

    Dim incNo As Long 'Must be Long not Integer be able to store 8 digit Inc number, otherwise 'Overflow Runtime 6' error.

    Sh = ActiveSheet.name

    r = ActiveCell.Row

    incNo = Cells(r, 1)

    ans = MsgBox("Would you like to move the current row with Inc No: " & incNo & " to the ""Completed"" sheet?", vbYesNo, "Move Row!")

    If ans = vbYes Then

        ActiveSheet.Cells(r, "G").Interior.ColorIndex = xlNone

        ActiveSheet.Cells(r, "G") = "Completed"

        ActiveSheet.Cells(r, "N") = Date

        ActiveCell.EntireRow.Cut _

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

        MsgBox "Inc No: " & incNo & " from row number: " & r & " has been moved to ""Completed"" sheet"

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

    End If

End Sub

'Following does two things:

' 1) Separates UK records with Overseas by placing UK records at top,

' 2) it also sorts overseas records by Country name.

Sub SortByCountryUKonTop()

    Application.ScreenUpdating = False

    Dim strCol As String: strCol = GetTargetColumn()

    If strCol = "" Then

        End

    End If

    Dim lastRow, lastCol As Long, r As Long

    lastCol = Cells(1, Columns.count).End(xlToLeft).Column + 1

    Columns(lastCol).EntireColumn.Insert

    lastRow = Cells(Rows.count, 2).End(xlUp).Row

    For r = 1 To lastRow

        tVal = UCase(Trim(Cells(r, strCol).Value))

        If tVal = "UK" Then

            Cells(r, lastCol) = "000"

        Else

            Cells(r, lastCol) = tVal

        End If

    Next r

    ActiveSheet.UsedRange.Sort Key1:=Cells(1, lastCol), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

    Columns(lastCol).EntireColumn.Delete

    Application.ScreenUpdating = True

End Sub

'Following VBA code formats the exported-data, it:

' 1) Separates UK records with Overseas by placing Overseas' subs at top & UK records at the bottom of the table.

' 2) it also sorts overseas records by Country name.

Sub SortByCountryCode()

    Application.ScreenUpdating = False

    [A1].EntireColumn.Insert

    Dim lastRow, lastCol As Long, r As Long

    lastRow = Cells(Rows.count, 2).End(xlUp).Row

    For r = 1 To lastRow

        lastCol = Cells(r, Columns.count).End(xlToLeft).Column

        tVal = UCase(Trim(Cells(r, lastCol).Value))

        If tVal = "REPUBLIC OF" Then    'taking care of Trilogy-export's comma / double-quotes problem.

            tVal = UCase(Cells(r, lastCol).Offset(0, -1).Value) & ", " & tVal

            Cells(r, lastCol).Offset(0, -1).Value = tVal

            Cells(r, lastCol).Clear

        Else

            If Trim(Cells(r, lastCol).Value) <> tVal Then   'making sure if value in last col is UPPERCASE.

                Cells(r, lastCol).Value = tVal

            End If

        End If

        

        If IsNumeric(Left(tVal, 3)) Then

            Cells(r, 1) = tVal

        Else

            If IsNumeric(Mid(tVal, 2, 1)) Or IsNumeric(Mid(tVal, 3, 1)) Or tVal = "UK" Then

                Cells(r, 1) = "000"

            Else

                Cells(r, 1) = tVal

                'Cells(r, Columns.Count).End(xlToLeft).Copy Destination:=Cells(r, 1)

            End If

        End If

    Next r

    'ActiveSheet.Range("A1", "M" & lastRow).Sort Key1:=Range("A1"), Order1:=xlAscending, MatchCase:=False, Header:=xlNo

    ActiveSheet.UsedRange.Sort Key1:=Range("A1"), Order1:=xlAscending, MatchCase:=False, Header:=xlNo

    [A1].EntireColumn.Delete

    Application.ScreenUpdating = True

End Sub

'Changes case to ProperCase if 1st character is in lower case, ignoring ALL-CAPS, in given column (asks column-letter from user).

Sub ChangeCase2ProperIf1stCharLower_OLDER()

    Dim lastRow As Long, r As Long

    Dim tVal As String

    Dim col As Variant

    col = Application.InputBox(Prompt:="Enter column letter, in which you want to change lowercase values into ProperCase.")

    Debug.Print TypeName(col) & " - " & col

    If col = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf col = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        End

    End If

    Application.ScreenUpdating = False

    lastRow = Cells(Rows.count, 2).End(xlUp).Row

    For r = 2 To lastRow

        tVal = Trim(Cells(r, col))

        If UCase(Left(tVal, 1)) <> Left(tVal, 1) Then

            Cells(r, col) = WorksheetFunction.Proper(tVal)

        ElseIf UCase(tVal) = tVal And Len(tVal) > 3 Then 'applies ProperCase if all chars in UPPERCASE & more than 2 chars in cell

            Cells(r, col) = WorksheetFunction.Proper(tVal)

        End If

    Next r

    Application.ScreenUpdating = True

End Sub

Sub SplitAndJoinArray()

    Dim a() As String

    a() = Split([D1], " ")

    MsgBox [D1]

    'MsgBox UBound(a)

    MsgBox Join(a(), "-")

End Sub

'Changes case to ProperCase if 1st character is in lower case, ignoring ALL-CAPS, in given column (asks column-letter from user).

Sub ChangeCase2ProperIf1stCharLower()

    Dim lastRow As Long, r As Long

    Dim tVal As Variant

    Dim col As Variant

    col = Application.InputBox(Prompt:="Enter column letter, in which you want to change lowercase values into ProperCase.")

    Debug.Print TypeName(col) & " - " & col

    If col = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf col = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No text! you didn't enter anything."

        End

    End If

    

    Dim aWord() As String   'for each word in each cell.

    Dim Exclusions() As String

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

    'Exclusions() = Split("And, Of, For, To, With, In, On, A, An, The", ", ")  'One-liner array assignment.

    Application.ScreenUpdating = False

    lastRow = Cells(Rows.count, col).End(xlUp).Row

    For r = 1 To lastRow

        aWord() = Split(Cells(r, col), " ")

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

        'For Each tVal In aWord

            tVal = aWord(i)

            If UCase(tVal) = "BJFM" Then

                aWord(i) = "BJFM"

            ElseIf UCase(Left(tVal, 1)) <> Left(tVal, 1) Then

                aWord(i) = WorksheetFunction.Proper(tVal)

                For Each x In Exclusions

                   If tVal = x Then  'If InStr(tVal, x) Then

                        aWord(i) = LCase(tVal)

                   End If

                Next x

            ElseIf UCase(tVal) = tVal And Len(tVal) > 3 Then  'applies ProperCase if all chars in UPPERCASE & more than 2 chars in cell

                    aWord(i) = WorksheetFunction.Proper(tVal)

            End If

        Next i

        Cells(r, col) = Trim(Join(aWord, " "))

        Erase aWord

    Next r

    Application.ScreenUpdating = True

End Sub

'usage: IsInArray("item1", arrName) -> this will check if "item1" is in array arrName

'e.g. If (IsInArray(Cells(1, c), arr)) Then

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

    If UBound(arr) = -1 Then    'array is not initialised - if not checked here Match() will return "Type mismatch" error.

        IsInArray = False

        Exit Function

    Else

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

    End If

End Function

'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

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

'code also renames columns as per another array elements and finally sorts table as per column 1.

'Formats data for Detailed Email list:

Sub DeleteCols_RenameCols_SortByMailName()

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

    Dim new_names As Variant

    Dim arr_keep As Variant

    Dim lastRow As Long, lastCol As Integer, c As Integer, r As Long

    'Deleting unnecessary columns:

    'arr = Split("Account_No,Known_As,forenames,surname,language,title,filecode,area,Journal,type_code,source_code,prefix,MainTelNo,userdefined4,Mailing_Ref,address_type,postcode2,Post_Code_Group,Country_code,DXAddress,FaxNo,Postal_group_periodic", ",")

    arr = Split("Known_As,Language,filecode,Journal,type_code,source_code,Prefix,Mailing_Ref,address_type,postcode2,Post_Code_Group,Country_code,DXAddress,FaxNo,Postal_group_periodic", ",")

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

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

            Cells(1, c).EntireColumn.Delete

        End If

    Next c

    Call FormatEdTableWithHeader    'format entire table.

    'Renaming columns:

    arr_keep = Split("Account_No,forenames,surname,Mail_Name,title,department,position_,area,organisation,MainTelNo,userdefined4,addressline1,addressline2,addressline3,locality,postown,county,postcode,country", ",")

    new_names = Split("AccountNo,Forenames,Surname,MailName,Title,Department,Position,Area,Organisation,Tel,Email,Addressline1,Addressline2,Addressline3,Locality,PostTown,County,Postcode,Country", ",")

    For i = 1 To ActiveSheet.UsedRange.Columns.count

        If Cells(1, i) = arr_keep(i - 1) Then

            Cells(1, i).Value = new_names(i - 1)

        End If

        If Columns(i).ColumnWidth > 30 Then

            Columns(i).ColumnWidth = 30

        End If

    Next i

    

    'Sorting by MailName:

    ActiveSheet.UsedRange.Sort Key1:=Range("A1"), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

End Sub

'Only delete columns (no rename / no sort):

'Sub DeleteCols4Communigator() 'Icon-Name: "Delete Cols 4 Communigator"

Sub DeleteUnnecessaryCols() 'Icon-Name: "Delete Cols 4 Communigator"

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

    Dim lastRow As Long, lastCol As Integer, c As Integer, r As Long

    'Deleting unnecessary columns:

    arr = Split("Title,Subscription Rate Types,Price,Em,Ph,Full_Name,mail_name,Master,description,address_type,addressline1,addressline2,addressline3,area,Cost_Price,country,Country_code,county,Customer_Interest,interest,Interests,Subject,Customer_Keyword,keyword,department,DXAddress,Emailable,FaxNo,filecode,Job_No,Journal,Known_As,language,locality,Mailing_Ref,MainTelNo,Telephone,master_account,organisation,position_,Post_Code_Group,Postal_group_periodic,postcode,postcode2,postown,prefix,Purchase_Date,Qty,source_code,Stock_No,Total_Value,type_code,Tel,Phoneable,Start_Date,End_Date,Subscription_rate,Purchase_Price,Quantity,Subs-Type,Renewal,ActiveSub,Disabled,Deceased,Subs_Rate_Type,Cancelled,Lapsed,Position,PositionType", ",")

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

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

            Cells(1, c).EntireColumn.Delete

        End If

    Next c

    Call RenameTrilogyCols

    Call Delete1AlphabetLongFirstName

    Call FormatEdTableWithHeader    'format entire table.

End Sub

Sub Delete1AlphabetLongFirstName()

    Dim lastCol, c, ForenamesCol As Integer: lastCol = Cells(1, Columns.count).End(xlToLeft).Column

    For c = 1 To lastCol

        If InStr(1, CStr(Cells(1, c)), "Forenames", vbTextCompare) > 0 Or InStr(1, CStr(Cells(1, c)), "First Name", vbTextCompare) > 0 Then

            ForenamesCol = c

            Exit For

        End If

    Next c

    If ForenamesCol = 0 Then

        MsgBox "Dataset doesn't contain a 'Forenames' column."

        Exit Sub

    End If

    Columns(ForenamesCol + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    'Cells(1, ForenamesCol + 1) = "Forenames (excluding initials)"

    Cells(1, ForenamesCol + 1) = "Forenames"

    'B2 = Cells(2, ForenamesCol)

    Cells(2, ForenamesCol + 1).Formula = "=IF(OR(LEN(RC[-1])<=1,AND(LEN(RC[-1])=2,RIGHT(RC[-1])=""."")),"""",RC[-1])"

    Dim lastRow As String: lastRow = Cells(Rows.count, ForenamesCol).End(xlUp).Row 'ActiveSheet.UsedRange.Rows.Count

    Set fillDest = Range(Cells(2, ForenamesCol + 1), Cells(lastRow, ForenamesCol + 1))

    Cells(2, ForenamesCol + 1).AutoFill Destination:=fillDest

    Columns(ForenamesCol + 1).Copy

    Columns(ForenamesCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Columns(ForenamesCol).EntireColumn.Delete

    'Application.CutCopyMode = False

    'MsgBox "A column ""Forenames (without initials)"" has been inserted next to the ""Forenames"" column" _

    MsgBox "A column ""Forenames (without initials)"" has replaced the ""Forenames"" column" _

    & vbNewLine & "The new columns does not contain single-letter or one character long values in Forenames column."

    

End Sub

'Formats data for Postal Mailing List (i.e. keeps the addresses columns)

'Sub also does following: DeleteCols SwapCol2with3 RenameCols FormatAsTable

Sub DelCol_FormatsForPostalMailingList()

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

    Dim new_names As Variant

    Dim arr_keep As Variant

    Dim lastRow As Long, lastCol As Integer, c As Integer, r As Long

    'Deleting unnecessary columns:

    arr = Split("record_date,Interest,PositionType,Subject,Acc_No,AccountNo,Reference,Country_code,TelNo,E-Mail,Tel,Email,FaxNo,Title,Forenames,Surname,Account_No,Known_As,language,filecode,area,Journal,type_code,source_code,prefix,MainTelNo,userdefined4,Mailing_Ref,address_type,postcode2,Post_Code_Group,Country_code,DXAddress,FaxNo,Postal_group_periodic", ",")

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

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

            Cells(1, c).EntireColumn.Delete

        End If

    Next c

    'Call SwapCol2with3              'swaping contents of entire Column-B with Column-C : Position then Dept.

    Call RenameTrilogyCols          'rename columns to more readable.

    'Call FormatEdTableWithHeader    'format entire table.

End Sub

'Following sub swaps contents of entire Column-B with Column-C.

Sub SwapCol2with3()

    Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Columns("B:B").Cut Destination:=Columns("C:C")

    Columns("D:D").Cut Destination:=Columns("B:B")

    Columns("D:D").Delete Shift:=xlToLeft

End Sub

'Following finds the column header that contains "Email" or "Userdefined4", then runs Excels Remove Duplicate command on it.

Sub DedupeOnEmail()

    Dim lastCol, c, emailCol As Integer: lastCol = Cells(1, Columns.count).End(xlToLeft).Column

    For c = 1 To lastCol

        If InStr(1, CStr(Cells(1, c)), "email", vbTextCompare) > 0 Or InStr(1, CStr(Cells(1, c)), "userdefined4", vbTextCompare) > 0 Then  'on Email only

        'If InStr(1, CStr(Cells(1, c)), "account", vbTextCompare) > 0 Then   'on Account_no

            emailCol = c

            Exit For

        End If

    Next c

    If emailCol <> 0 Then

        ActiveSheet.UsedRange.RemoveDuplicates Columns:=emailCol, Header:=xlYes

    Else

        MsgBox """Email"" column not found." & vbNewLine & vbNewLine & "Worksheet must have a column with header-row containing term ""email""."

    End If

End Sub

'Only rename columns and sort:

Sub RenameTrilogyCols() 'Icon-Name: Rename Trilogy Cols

    Dim lastCol, c As Integer: lastCol = Cells(1, Columns.count).End(xlToLeft).Column

    'Check & rename each columns:

    For c = 1 To lastCol

        Cells(1, c) = WorksheetFunction.Proper(Cells(1, c))

        If Cells(1, c) = "Userdefined4" Then

            Cells(1, c) = "Email"

        ElseIf Cells(1, c) = "Mail_Name" Then Cells(1, c) = "Full_Name"

        ElseIf Cells(1, c) = "Maintelno" Then Cells(1, c) = "Telephone"

        ElseIf Cells(1, c) = "Userdefined4" Then Cells(1, c) = "Email"

        ElseIf Cells(1, c) = "Position_" Then Cells(1, c) = "Position"

        ElseIf Cells(1, c) = "Master_account" Then Cells(1, c) = "Master_Acc"

        'ElseIf Cells(1, c) = "account_no" Then Cells(1, c) = "Account_no"

        'ElseIf Cells(1, c) = "forenames" Then Cells(1, c) = "Forenames"

        'ElseIf Cells(1, c) = "surname" Then Cells(1, c) = "Surname"

        'ElseIf Cells(1, c) = "Mail_name" Then Cells(1, c) = "Full_Name"

        'ElseIf Cells(1, c) = "Title Forenames Surname" Then Cells(1, c) = "Full_Name"

        'ElseIf Cells(1, c) = "department" Then Cells(1, c) = "Department"

        'ElseIf Cells(1, c) = "keyword" Then Cells(1, c) = "Keyword"

        'ElseIf Cells(1, c) = "email" Then Cells(1, c) = "Email"

        'ElseIf Cells(1, c) = "postcode" Then Cells(1, c) = "Post_Code"

        'ElseIf Cells(1, c) = "country" Then Cells(1, c) = "Country"

        'ElseIf Cells(1, c) = "organisation" Then Cells(1, c) = "Organisation"

        'ElseIf Cells(1, c) = "area" Then Cells(1, c) = "Area"

        End If

    Next c

'    ActiveSheet.UsedRange.Sort Key1:=Range("A1"), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

End Sub

'Rename and sort columns:

Sub RenameCols_SortByMailName()

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

    Dim new_names As Variant

    Dim lastRow As Long, lastCol As Integer, c As Integer, r As Long

    arr_keep = Split("Account_No,forenames,surname,Mail_Name,department,position_,area,organisation,userdefined4,addressline1,addressline2,addressline3,locality,postown,county,postcode,country", ",")

    'Renaming columns:

    new_names = Split("AccountNo,Forenames,Surname,MailName,Department,Position,Area,Organisation,Email,Addressline1,Addressline2,Addressline3,Locality,PostTown,County,Postcode,Country", ",")

    c = ActiveSheet.UsedRange.Columns.count

    For i = 1 To c

        If Cells(1, i) = arr_keep(i - 1) Then

            Cells(1, i).Value = new_names(i - 1)

        End If

    Next i

'    ActiveSheet.UsedRange.Sort Key1:=Range("A1"), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

End Sub

'Following adds the EdColWidth columns, to find any overly long entries in each column - once finished run Sub DelLenCols().

Sub AddLenCols()

    Dim lastCol, c, col As Integer: c = 0

    Dim lastRow As Long

    Dim colRng As Range

    lastCol = ActiveSheet.UsedRange.SpecialCells(11).Column

    'LastCol = Cells(1, Columns.count).End(xlToLeft).Column

    lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row

    'LastRow = Cells(Rows.count, 1).End(xlUp).row

    For col = 2 To lastCol + 1

        c = c + 2

        Columns(c).Insert Shift:=xlToRight ', CopyOrigin:=xlFormatFromLeftOrAbove

        Cells(1, c) = "EdColWidth"

        Cells(2, c).Formula = "=LEN(RC[-1])"

        Set colRng = Range(Cells(2, c), Cells(lastRow, c))

        If lastRow > 2 Then

            Cells(2, c).AutoFill Destination:=colRng

        End If

        colRng.Value = colRng.Value

        colRng.Interior.ColorIndex = 15

    Next col

    'Range("A1", Cells(LastRow, LastCol)).Sort Key1:=Range("B1"), Order1:=xlDescending, MatchCase:=False, Header:=xlYes

    [A1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlDescending, MatchCase:=False, Header:=xlYes

    Range(Columns(1), Columns(lastCol * 2)).AutoFit

End Sub

'Following deletes the EdColWidth columns

Sub DelLenCols()

    Dim col, lastCol As Integer: lastCol = Cells(1, Columns.count).End(xlToLeft).Column

    For col = 2 To lastCol + 1

        If Cells(1, col) = "EdColWidth" Then

            Columns(col).EntireColumn.Delete

        End If

    Next col

End Sub

Sub SortDesc()

    ActiveSheet.UsedRange.Sort Key1:=ActiveCell, Order1:=xlDescending, MatchCase:=False, Header:=xlYes

End Sub

'Tel number validation - Highlight problemetic ones & fix too many white-spaces:

Sub ValidateTelNumber()

    Dim tVal, c, TelNumColumn As String

    'TelNumColumn = "F"       'set target COLUMN here, which contains telephone numbers.

    TelNumColumn = GetTargetColumn()

    If TelNumColumn = "" Then

        End

    End If

    On Error GoTo Fin

    Dim lastRow As Long, r As Long

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    Dim i, j, errCount As Integer

    Dim errRow As String: errRow = ""

    Application.ScreenUpdating = False

    lastRow = Cells(Rows.count, 1).End(xlUp).Row

    For r = 2 To lastRow

        tVal = Cells(r, TelNumColumn)

        If Trim(tVal) = "" Then

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        re.Pattern = "^\s+.|.+$\s+" 'check & fix any leading or trailing whitespace(s)

        If re.test(tVal) Then

        'If Left(tVal, 1) = " " Or Right(tVal, 1) = " " Then 'can ONLY check Single space

            tVal = Trim(Cells(r, TelNumColumn))

            Cells(r, TelNumColumn) = tVal  'applying trim() to cell

        End If

        re.Pattern = "\s{2,}"   'remove multiple consecutive spaces

        If re.test(tVal) Then

        're.Replace() returns <arg1> but with matched-patterns (in arg1) replaced with <arg2>

            tVal = re.Replace(tVal, "")     'replacing spaces in tVal variable

            Cells(r, TelNumColumn) = tVal            'writing tVal back on cell

        End If

        re.Pattern = "[^0-9-+()\s]+"

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        re.Pattern = "[+]{2,}"   'If InStr(2, tVal, "+") > 0 Then

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

      

        re.Pattern = "^0{3,}"  'first 0 repeating consequtively more than 2 times

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        re.Pattern = "(.)\1{4,}"  'a char repeating consequtively more than 4 times

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        re.Pattern = "^(.)\1{3,}"  'first char repeating more than 3 times

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        

        If Len(tVal) < 5 Or Len(tVal) > 30 Then    'checking length min 4 & max 30 chars incl spaces +() etc.

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

NextIteration:

    Next r

    errCount = UBound(Split(errRow, ".  "))

    Debug.Print errRow

    MsgBox errCount & " error(s)/blank(s) found in following row-numbers:" & vbNewLine & errRow & vbNewLine & "(row-number(s) with erroneous email addresses also printed in the Immediate window.)"

    'MsgBox errCount & " errors/blanks found."

Fin:

    Set re = Nothing

    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description

    Application.ScreenUpdating = True

End Sub

'Email validation - Highlight problemetic ones & fix too many white-spaces:

Sub ValidateEmail()

    Dim tVal, c As String

    Dim EmailColumn As Variant: EmailColumn = GetColumnNumberByHeaderName("email")

    If EmailColumn = 0 Then

        'EmailColumn = "E"       'set target COLUMN here, which contains email addresses.

        EmailColumn = GetTargetColumn()

        If EmailColumn = "" Then End

    End If

    Application.ScreenUpdating = False

    On Error GoTo Fin

 'LESS RESTRICTIVE EMAIL ADDRESSES:

    'VALID SPECIAL CHARS: Characters !#$%&'*+-/=?^_`{|}~ (ASCII: 33, 35-39, 42, 43, 45, 47, 61, 63, 94-96, 123-126)

    'VALID but IN QUOTES ONLY: Space"(),:;<>@[\] (ASCII: 32, 34, 40, 41, 44, 58, 59, 60, 62, 64, 91-93)

    'VALID IN QUOTES+ESCAPED: space, backslash \ and "quotation mark" (ASCII: 32, 92, 34) must also be preceded by a backslash \ (e.g. "\ \\\"").

 'VERY RESTRICTIVE EMAIL ADDRESSES:

    'ONLY: alphanumerics, dot (.), underscore (_) and hyphen (-)

    Const strREPattern = "^([a-z0-9'_\-\.&]+)@[a-z0-9\-\.]+\.([a-z]{2,4})$"  'IgnoreCase must be used.

    Dim lastRow As Long, r As Long

    Dim i, j, errCount As Integer: errCount = 0

    Dim errRow As String: errRow = ""

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    re.IgnoreCase = True

    lastRow = Cells(Rows.count, EmailColumn).End(xlUp).Row

    For r = 2 To lastRow

        tVal = Cells(r, EmailColumn)

        If Trim(tVal) = "" Then

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        

        re.Pattern = "\s+"   'remove spaces (anywhere) in string

        If re.test(tVal) Then

        're.Replace() returns <arg1> but with matched-patterns (in arg1) replaced with <arg2>

            tVal = re.Replace(tVal, "")     'replacing spaces in tVal variable

            Cells(r, EmailColumn) = tVal            'writing tVal back on cell

        End If

        re.Pattern = "(.)\1{3,}"  'a char repeating consequtively more than 4 times

        If re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        If Len(tVal) <= 5 Or Len(tVal) > 254 Then    'length must be between min 6 & max 254 chars.

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

        re.Pattern = strREPattern

        If Not re.test(tVal) Then

            Call HighlightCell(Cells(r, EmailColumn))

            errRow = errRow & r & ".    "

            GoTo NextIteration

        End If

NextIteration:

    Next r

    If errRow = "" Then

        MsgBox "No erroneous email addresses found."

    Else

        errCount = UBound(Split(errRow, ".  "))

        MsgBox errCount & " errors/blanks found in following row-numbers:" & vbNewLine & errRow & vbNewLine & "(row-number also printed in the Immediate window)"

    End If

Fin:

    Set re = Nothing

    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description

    Application.ScreenUpdating = True

End Sub

'Following hightlights the passed cell ref.

Sub HighlightCell(cellAddr As Range)

            cellAddr.Interior.ColorIndex = 19

            cellAddr.Font.ColorIndex = 3

            cellAddr.Font.Bold = True

End Sub

'Sub ValidateIfEUCountries()

Sub ValidateHighlightEUCountries()

    'All EU countries:

        'Albania,Andorra,Armenia,Austria,Azerbaijan,Belarus,Belgium,Bosnia,Bulgaria,Croatia,Cyprus,Czech,Denmark,Estonia,Finland,France,Georgia,Germany,Greece,Hungary,Iceland,Ireland,Italy,Kazakhstan,Kosovo,Latvia,Liechtenstein,Lithuania,Luxembourg,Macedonia,Malta,Moldova,Monaco,Montenegro,Netherlands,Norway,Poland,Portugal,Romania,Russia,Marino,Serbia,Slovakia,Slovenia,Spain,Sweden,Switzerland,Turkey,Ukraine,Vatican

        'FULLNAMES: 'Albania,Andorra,Armenia,Austria,Azerbaijan,Belarus,Belgium,Bosnia and Herzegovina,Bulgaria,Croatia,Cyprus,Czech Republic,Denmark,Estonia,Finland,France,Georgia,Germany,Greece,Hungary,Iceland,Ireland,Italy,Kazakhstan,Kosovo,Latvia,Liechtenstein,Lithuania,Luxembourg,Macedonia,Malta,Moldova,Monaco,Montenegro,Netherlands,Norway,Poland,Portugal,Romania,Russia,San Marino,Serbia,Slovakia,Slovenia,Spain,Sweden,Switzerland,Turkey,Ukraine,Vatican City

    

    Dim countryColNum As Integer: countryColNum = GetColumnNumberByHeaderName("country")  'if not found then 0 is returned.

    If countryColNum = 0 Then

        countryColNum = ColumnLetterToNumber(GetTargetColumn)

    End If

    Dim lastRow As Long: lastRow = Cells(Rows.count, countryColNum).End(xlUp).Row

    Dim arrEUCountries() As String

    arrEUCountries() = Split("Albania,Andorra,Armenia,Austria,Azerbaijan,Belarus,Belgium,Bosnia,Bulgaria,Croatia,Cyprus,Czech,Denmark,Estonia,Finland,France,Georgia,Germany,Greece,Hungary,Iceland,Ireland,Italy,Kazakhstan,Kosovo,Latvia,Liechtenstein,Lithuania,Luxembourg,Macedonia,Malta,Moldova,Monaco,Montenegro,Netherlands,Norway,Poland,Portugal,Romania,Russia,Marino,Serbia,Slovakia,Slovenia,Spain,Sweden,Switzerland,Ukraine,Vatican", ",")

    For r = 2 To lastRow

        For Each country In arrEUCountries

            If InStr(1, Cells(r, countryColNum), country, vbTextCompare) Then

            'If Cells(r, countryColNum) Like "*" & country & "*" Then   'Requires: Option Compare Text

                Cells(r, countryColNum).Interior.ColorIndex = 24

                Exit For

            End If

        Next

    Next r

End Sub

Sub TestLikeOperator()

    x = "abc"

    MsgBox "zzzabcssss" Like "*" & x & "*"    'Requires: Option Compare Text

    'MsgBox InStr(1, "zzzabcssss", "axc", vbTextCompare)

End Sub

Sub ValidateCountryNames()

'All EU countries:

    'Albania,Andorra,Armenia,Austria,Azerbaijan,Belarus,Belgium,Bosnia and Herzegovina,Bulgaria,Croatia,Cyprus,Czech Republic,Denmark,Estonia,Finland,France,Georgia,Germany,Greece,Hungary,Iceland,Ireland,Italy,Kazakhstan,Kosovo,Latvia,Liechtenstein,Lithuania,Luxembourg,Macedonia,Malta,Moldova,Monaco,Montenegro,Netherlands,Norway,Poland,Portugal,Romania,Russia,San Marino,Serbia,Slovakia,Slovenia,Spain,Sweden,Switzerland,Turkey,Ukraine,Vatican City

'All countries:

'"AFGHANISTAN REPUBLIC#   ALBANIA REPUBLIC OF#    ANDORRA#    ANGOLA REPUBLIC OF# ANGUILLA (I.O. BR.)#    ANTIGUA AND BARBUDA#    ARGENTINA#  ARMENIA REPUBLIC OF#    ARUBA, (CODE: NAN)# AUSTRALIA#  AZERBAIJAN REPUBLIC#    AZORES AND MADERA#  BAHRAIN#    BARBADOS#   BANCA COMMERCIALE ITALIANA (FAO)#   BURUNDI#    BELGIUM#    BENIN#  BERMUDA#    BANGLADESH# BAHAMAS#    BHUTAN# BOSNIA AND HERZEGOVINA# BURKINA FASO#   BOLIVIA#    BONAIRE#    BOTSWANA REPUBLIC OF#   BRAZIL# BRUNEI# BULGARIA#   BRITISH VIRGIN ISLANDS# BELARUS REPUBLIC OF#    BELIZE# CENTRAL AFRICAN REPUBLIC#   CANADA# C.A.S.A.#   CAYMAN ISLANDS# CARIBBEAN COMMUNITY#    CZECH REPUBLIC THE# CHANNEL IS., (CODE: UK)#    CHAD#   CHILE#  COOK ISLANDS#   CAMBODIA KINGDOM OF#    CAMEROON REPUBLIC OF#   CORSE, FRANCIA (CODE: FRA)# COMOROS#    COLOMBIA#   COSTA RICA# CHINA PEOPLE'S REPUBLIC#    FORMER CODE OF: MIC#    CROATIA REPUBLIC OF#    CUBA#   CURACAO#    CAPE VERDE# CYPRUS# DENMARK#    DJIBOUTI#   DOMINICA#   DOMINICAN REPUBLIC

'# KOREA PEOPLES DEMOCRATIC REPUBLIC# ECUADOR#    EGYPT#  EL SALVADOR#    EQUATORIAL GUINEA#  ERITREA#    ESTONIA REPUBLIC OF#    ETHIOPIA#   IS.FAEROE,DANIMARCA (CODE:DEN)# FRENCH ANTILLES#    FERNANDO POO, (CODE: EQG)#  FFOA - FORMER FAO/WFP STAFF MEMBERS#    FRENCH GUIANA#  FIJI#   FINLAND#    IS. FALKLAND#   FRENCH POLYNESIA#   FRANCE# GABON#  GAMBIA REPUBLIC OF THE# GUINEA-BISSAU#  GEORGIA REPUBLIC OF#    GERMANY#    GHANA#  GIBRALTAR#  CONFERENCE,COUNCIL & PROTOCOL AFF.DIV.# GREECE# GREENLAND#  GRENADA#    GUATEMALA#  GUADELOUPE# GUINEA# GUYANA# HAITI#  HOLY SEE (CITTA DEL VATICANO)#  HONG KONG#  HONDURAS#   HORN, CAPE (CODE: CHI)# HUNGARY#    ICELAND#    INDIA#  INDONESIA#  IRAN#   IRAQ#   ISRAEL# ITALY#  COTE D'IVOIRE#  JAMAICA#    JORDAN HASHEMITE KINGDOM#   JAPAN#  KAZAKHSTAN REPUBLIC#    KENYA REPUBLIC OF#  KIRIBATI#   KUWAIT# KYRGYZSTAN REPUBLIC#    LAO PEOPLE'S DEMOCRATIC REPUBLIC#   LATVIA REPUBLIC OF# LEBANON#    LEGAL OFFICE#   LEEWARD IS.#    LESOTHO#    LIBYAN ARAB JAMAHIRIYA# LIECHTENSTEIN

'#  LIBERIA#    LITHUANIA REPUBLIC OF# LUXEMBOURG GRAND DUC.#  ISLE OF MAN, (CODE: UK)#    MACAO#  MADERA (CODE: AZR)# MADAGASCAR# MARTINIQUE# MAURITIUS REPUBLIC OF#  MARSHALL ISLANDS REP.#  MAURITANIA# THE FORMER YUGOSLAV (MACEDONIA)#    MALDIVES#   MEXICO# MICRONESIA FEDERATED#   MALI#   MALAWI# MONACO# MOLDOVA, REPUBLIC OF#   MONGOLIA#   MOROCCO#    MONTSERRAT# MOZAMBIQUE# IS. MARIANNE#   MYANMAR UNION OF#   NAMIBIA REPUBLIC OF#    NETHERLANDS ANTILLES#   NAURU#  NEW CALEDONIA#  NEPAL#  NIGER#  NICARAGUA#  NIGERIA#    NIUE ISLAND#    NORWAY# SULTANATE OF OMAN#  PAKISTAN#   PALESTINE#  PANAMA# PARAGUAY#   PERU#   PHILIPPINES#    PAPUA NEW GUINEA#   POLAND# PORTUGAL#   CONGO REPUBLIC OF#  PUERTO RICO#    QATAR#  REUNION#    KOREA REPUBLIC OF#  ROMANIA#    RWANDA# IS. RYUKYU# SOUTH AFRICA#   SAMOA#  SARAWAK (CODE: MAL)#    SAUDI ARABIA, KINGDOM OF#   SENEGAL#    SEYCHELLES# SIERRA LEONE#   SINGAPORE#  SLOVAK REPUBLIC#    ST.MARTIN, (CODE: NAN)# SOVEREIGN ORDER OF MALTA#   SAN MARINO

'# SOLOMON ISLANDS#    SPAIN#  SRI LANKA#  ST.CHRISTOPHER & NEVIS (CODE: STK)#    ST. EUSTATIUS (NETHERLANDS ANTILLES)#   ST. KITTS & NEVIS#  ST. LUCIA#  ST. MARTIN (NETHERLANDS ANTILLES)#  SAO TOME AND PRINCIPE#  ST. VINCENT & THE GRENADINES#   SUDAN#  SURINAME#   SLOVENIA, REPUBLIC OF#  SWAZILAND#  SWEDEN# SYRIAN ARAB REPUBLIC#   TAJIKISTAN REPUBLIC#    TURKS & CAICOS ISLANDS# THAILAND#   IS. TIMOR#  TOGO#   TOKELAU ISLANDS#    TONGA#  TRINIDAD AND TOBAGO#    U.S. TRUST TERRITORI#   TURKMENISTAN#   TUNISIA#    TURKEY# TUVALU# TAIWAN (FORMOSA)#   UNITED ARAB EMIRATES#   UGANDA# UK# UKRAINE#    TANZANIA UNITED REPUBLIC#   URUGUAY#    UNITED STATES OF AMERICA#   RUSSIAN FEDERATION# US VIRGIN ISLANDS#  UZBEKISTAN REPUBLIC#    VANUATU#    VENEZUELA#  VIET NAM#   VIRGIN ISLANDS (CODES: BVI - UVI)#  UNITED NATIONS WORLD FOOD COUNCIL#  WORLD FOOD DAY (CODE: GII)# WALLIS & FUTUNA IS.#    WEST IRIAN, (CODE: INS)#    WINDWARD AND LEEWARD#   YEMEN REPUBLIC OF#  YUGOSLAVIA# ZAIRE#  ZAMBIA

'# ZIMBABWE#   NORTHERN IRELAND#   Conferences UK# AUSTRIA#    ST. HELENA ISLAND#  SOMALIA#   NETHERLANDS#    SERBIA# ALGERIA#    MALTA#  IRELAND#    MALAYSIA#   NEW ZEALAND#    SWITZERLAND#"

End Sub

Function EdFuzzyMatch(s1 As String, s2 As String)

    s1 = Trim(s1)

    s2 = Trim(s2)

    If s1 = s2 Then

        EdFuzzyMatch = 100

        Exit Function

    End If

    'strLen = IIf(Len(s1) > Len(s2), s1, s2)  'whichever is longer.

    strLen = IIf(Len(s1) < Len(s2), s1, s2)  'whichever is shorter.

    Similarity = 0

    For c = 1 To strLen

        If InStr(1, s1, Mid(s2, c, 1), 1) Then

        Similarity = Similarity + 1

        'Str1 = Replace(Str1, Mid(Str2, c, 1), "*", 1, 1)

        End If

    Next c

Done:

    EdFuzzyMatch = 100 * Similarity / strLen

End Function

'"Application." vs "Application.Worksheetfunction."):

'    If error occurs, "Application.<function>" does not throws any errors, whereas

'    "Application.Worksheetfunction.<function>" throws RunTime error, hence requires you to provide

'    some error-handle mechanism (e.g. using: ON ERROR RESUME NEXT or GOTO <named-block>).

Sub MatchFunctionErrorHandlingTest()

    If IsError(Application.Match(38, Array(2, 3, 4, 6), 0)) Then    'No error

    'If IsError(Application.WorksheetFunction.Match(38, Array(2, 3, 4, 6), 0)) Then  'throws runtime-error if no match found.

        'x = Application.Match(Cells(2, "B"), "A2:A41", 0)

        'MsgBox TypeName(x)

        MsgBox "Error: No match found"

    Else

        MsgBox "no err: match found"

    End If

End Sub

'Follwing code collapses the table structured, left-align data with staggerred right-most columns removing any gaps/empty-cells.

'Slower-Execution-Version-1: uses Sheet-Navigation (using "Goto Cells().End(xlToLeft)"), instead of traversing each cell in (each) row.

Sub CollapseTableStructureLeftAglignData_byNavigating()

    Call ConfirmRun("CollapseTableStructureLeftAglignData_byNavigating")

    Dim sngStart, sngEnd, sngElapsed As Single

    sngStart = Timer                               ' Get start time.

    ScreenUpdating = False

    endRow = ActiveSheet.UsedRange.Rows.count

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

    'EndRow = 260

    For r = endRow To 1 Step -1

        Application.GoTo Cells(r, Columns.count).End(xlToLeft)

        Do

            Selection.End(xlToLeft).Select    'Select last column

            If ActiveCell.Column = 1 Then

                Exit Do

            End If

            If IsEmpty(ActiveCell.Offset(0, -1)) Then

                ActiveCell.Offset(0, -1).Delete Shift:=xlToLeft

            End If

        Loop Until ActiveCell.Column = 1

    Next r

    ScreenUpdating = True

    

    sngEnd = Timer                                 ' Get end time.

    sngElapsed = Format(sngEnd - sngStart, "Fixed") ' Elapsed time.

    MsgBox ("Empty Columns deleted." & vbNewLine & vbNewLine & "The code took " & sngElapsed & " seconds to run.")

End Sub

'Follwing code collapses the table structured, left-align data with staggerred right-most columns removing any gaps/empty-cells.

'Faster-Execution-Version-2: traverses/loops each cell in (each) row (delete if empty), instead of using Sheet-Navigation (using "Goto Cells().End(xlToLeft)")

Sub CollapseTableStructureLeftAglignData()

    Call ConfirmRun("CollapseTableStructureLeftAglignData")

    Dim aCell As Range

    Set aCell = Rows(1).Find(What:="addressline", LookIn:=xlValues, MatchCase:=False, LookAt:=xlPart, SearchFormat:=False)

    If Not aCell Is Nothing Then

        aCell.EntireRow.Delete

    End If

    Dim sngStart, sngEnd, sngElapsed As Single

    sngStart = Timer                               ' Get start time.

    ScreenUpdating = False

    endRow = ActiveSheet.UsedRange.Rows.count

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

    'EndRow = 260

    For r = endRow To 1 Step -1

        'For c = Cells(r, Columns.Count).End(xlToLeft).Offset(0, -1).Column To 1 Step -1 'code breaks if 1st-column has only white-space

        For c = Cells(r, Columns.count).End(xlToLeft).Column To 1 Step -1

            If IsEmpty(Cells(r, c)) Then

                Cells(r, c).Delete Shift:=xlToLeft

            End If

        Next c

    Next r

    ScreenUpdating = True

    

    sngEnd = Timer                                 ' Get end time.

    sngElapsed = Format(sngEnd - sngStart, "Fixed") ' Elapsed time.

    MsgBox ("Empty Columns/Cells Deleted, your data is no longer structured." & vbNewLine & vbNewLine & "The code took " & sngElapsed & " seconds to run.")

End Sub

'Pleace the cellpointer/cursor in the column where you want an additional column containing duplicate-row-counts to be inserted.

'Following code inserts an additional column at current cursor posion, then populates it with duplicate-row-counts.

'Note: this only looks/eveluates the columns on the left of the Current Cursor Position.

'Assumptions: Data is in tabular structure & has Top-Header-Row.

Sub DuplicateRowFinder()

    Dim col As Variant

    col = Application.InputBox(Prompt:="Enter column letter, where an additional column with duplicate-row-counts can be inserted. (e.g. C for third column)" _

        & vbNewLine & vbNewLine & "Note: only columns on the left are checked for duplications.", Title:="Column Letter")

    Debug.Print TypeName(col) & " - " & col

    If col = False Then  'user cancelled - clicking 'Cancel' button returns Boolean-False (NOT vbCancel).

        End

    ElseIf col = "" Then    'user clicked OK without inputing anything, returns empty-string "".

        MsgBox "No column letter entered, goodbye."

        End

    End If

    Dim lastCol, concatCol, sumProd, arg1, arg2 As String: lastCol = Range(col & "1").Column

    Dim lastRow, concatRow As String: lastRow = ActiveSheet.UsedRange.Rows.count

    Dim fillDest As Range

    Columns(lastCol).EntireColumn.Insert Shift:=xlToRight

    'ActiveCell.End(xlUp).Select

    'Range(col & "1").Select

'    ActiveCell.Value

    Range(col & "1") = "Duplicate-Row-Count"

    Range(col & "2").Select

    'ActiveCell.Offset(1, 0).Select

    Set fillDest = Range(Cells(2, lastCol), Cells(lastRow, lastCol))

    arg1 = "A" & ActiveCell.Row

    arg2 = "$A$2:$A$" & lastRow

    For i = 2 To lastCol - 1

        concatCol = Split(Cells(ActiveCell.Row, i).Address(True, False), "$")(0)

        concatRow = concatRow & ActiveCell.Row

        arg1 = arg1 & "&" & concatCol & ActiveCell.Row

        arg2 = arg2 & "&" & "$" & concatCol & "$2:$" & concatCol & "$" & lastRow

    Next i

    sumProd = "=SUMPRODUCT(--(" & arg1 & "=" & arg2 & "))"

    ActiveCell.Formula = sumProd

    ActiveCell.AutoFill Destination:=fillDest

    ActiveSheet.UsedRange.Sort Key1:=Cells(1, lastCol), Order1:=xlDescending, MatchCase:=False, Header:=xlYes

    fillDest.Interior.ColorIndex = 24

    'MsgBox "If the 'Duplicate-Row-Count' column contains value >= 2, then delete the duplicate row(s) until it shows '1'", vbInformation

    MsgBox "All duplicate rows will contain value >= 2 in the 'Duplicate-Row-Count' column (and unique rows will have value 1)", vbInformation

End Sub

'Following extracts unique values from all the rows in Column-A and insert them in Col-A replacing existing values:

'This is useful to remove duplicate and extract/get distinct values from each row, which is inserted in the last row.

Sub InsertUniqueValues_RemoveDupes()

Dim rng As Range, c As Range, s, i As Long

Application.ScreenUpdating = False

Set rng = Range("A1:A" & Range("A" & Rows.count).End(xlUp).Row)

With CreateObject("Scripting.Dictionary")

  For Each c In rng

    If c <> "" Then

      If InStr(c, ",") Then  'comma-separated.

      'If InStr(c, " ") Then  'space-separated.

        s = Split(Trim(c), ",")  'comma-separated.

        's = Split(Trim(c), " ")  'space-separated.

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

          If Not .Exists(s(i)) Then

            .Add s(i), s(i)

          End If

        Next i

        c.Value = Join(.Keys, ",")

      End If

    End If

  Next c

End With

Application.ScreenUpdating = True

End Sub

'Following code inserts a new sheet with list of account_nos that need to be marked as DoNotSendEmail in Trilogy.

Sub BouncedEmailListUpdate()

'MostRecentBounceReason

    Dim lastRow As Long

    Dim Sh As Worksheet

    Dim bounceReasonCol As Integer: bounceReasonCol = GetColumnNumberByHeaderName("MostRecentBounceReason")

    If bounceReasonCol = 0 Then

        MsgBox "MostRecentBounceReason column-header not found on current sheet, can't export Bournced email list."

        End

    End If

    ActiveSheet.UsedRange.AutoFilter Field:=bounceReasonCol, Criteria1:=Array("bad-configuration", _

        "bad-domain", "bad-mailbox", "blacklist-related", "Complaint", _

        "content-related", "inactive-mailbox", "invalid-sender", "policy-related", _

        "reputation-related", "spam-related", "Unknown"), Operator:=xlFilterValues

        

    Dim accNumCol As Integer: accNumCol = GetColumnNumberByHeaderName("Accountnumber")

    If accNumCol = 0 Then

        MsgBox "Accountnumber column-header not found on current sheet, can't export Bournced email list."

        End

    End If

    ActiveSheet.UsedRange.AutoFilter Field:=accNumCol, Criteria1:="<>"

    Set Sh = Sheets.Add(after:=ActiveSheet)

    [A1] = "AccountNo"

    [B1] = "DoNotEmail"

    [C1] = "EmailDeclined"

    Sheets(1).Select      'ActiveSheet.Next.Select

    Range(Cells(2, accNumCol), Cells(Rows.count, accNumCol).End(xlUp)).Copy Destination:=Sheets(2).Range("A2")

    Sheets(2).Select

'    Range("B2") = "Y"

'    Range("C2") = "Y"

    'LastRow = Cells(Rows.count, "A").End(xlUp).row

    lastRow = GetLastRow(Sh)

'    Range("B2").AutoFill Destination:=Sheets(2).Range("B2:B" & lastRow)

'    Range("C2").AutoFill Destination:=Sheets(2).Range("C2:C" & lastRow)

    Sheets(2).Range("B2:B" & lastRow) = "Y"

    Sheets(2).Range("C2:C" & lastRow) = "Y"

    Range("A1").Select

End Sub

'Following code inserts a new sheet with list of account_nos that need to be marked as DoNotSendEmail in Trilogy.

Sub UnsubscribedEmailListUpdate2()

'MostRecentBounceReason

    Dim targetCol As Integer: targetCol = GetColumnNumberByHeaderName("MostRecentUnsubscribeCampaign")

    If targetCol = 0 Then

        MsgBox "MostRecentUnsubscribeCampaign column-header not found in current sheet, can't export Unsubscribed list."

        End

    End If

    'ActiveSheet.UsedRange.AutoFilter Field:=targetCol, Criteria1:=Array("bad-domain", "bad-mailbox", "Unknown"), Operator:=xlFilterValues

    Dim accNumCol As Integer: accNumCol = GetColumnNumberByHeaderName("Accountnumber")

    If accNumCol = 0 Then

        MsgBox "Accountnumber column-header not found on current sheet, can't export Unsubscribed email list."

        End

    End If

    ActiveSheet.UsedRange.AutoFilter Field:=accNumCol, Criteria1:="<>"

    Sheets.Add after:=ActiveSheet

    [A1] = "AccountNo"

'    [B1] = "Keywords"

    [B1] = "DoNotEmail"

'    [C1] = "EmailDeclined"

    Sheets(1).Select      'ActiveSheet.Next.Select

    Range(Cells(2, accNumCol), Cells(Rows.count, accNumCol).End(xlUp)).Copy Destination:=Sheets(2).Range("A2")

    'If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData  'clear the AutoFilter

    If ActiveSheet.AutoFilterMode Then Cells.AutoFilter  'clear the AutoFilter

    Sheets(2).Select

    Range("B2") = "Y"

'    Range("C2") = "Y"

'    Sheets(2).Range("B2:B" & lastRow) = "unengaged_socialcare_Mar17"

    lastRow = Cells(Rows.count, "A").End(xlUp).Row

''    Range("B2").AutoFill Destination:=Sheets(2).Range("B2:B" & lastRow)

    Sheets(2).Range("B2:B" & lastRow) = "Y"

''    Range("C2").AutoFill Destination:=Sheets(2).Range("C2:C" & lastRow)

'    'Sheets(2).Range("C2:C" & lastRow) = "Y"

    Range("A1").Select

End Sub

'Following code inserts a new sheet with list of account_nos that need to be marked as DoNotSendEmail in Trilogy.

Sub UnsubscribedEmailListUpdate() '- Keywords update

'MostRecentBounceReason

    Dim targetCol As Integer: targetCol = GetColumnNumberByHeaderName("MostRecentUnsubscribeCampaign")

    If targetCol = 0 Then

        MsgBox "MostRecentUnsubscribeCampaign column-header not found in current sheet, can't export Unsubscribed list."

        End

    End If

    'ActiveSheet.UsedRange.AutoFilter Field:=targetCol, Criteria1:=Array("bad-domain", "bad-mailbox", "Unknown"), Operator:=xlFilterValues

    Dim accNumCol As Integer: accNumCol = GetColumnNumberByHeaderName("Accountnumber")

    If accNumCol = 0 Then

        MsgBox "Accountnumber column-header not found on current sheet, can't export Unsubscribed email list."

        End

    End If

    ActiveSheet.UsedRange.AutoFilter Field:=accNumCol, Criteria1:="<>"

    Sheets.Add after:=ActiveSheet

    [A1] = "AccountNo"

    [B1] = "Keywords"

'    [B1] = "DoNotEmail"

'    [C1] = "EmailDeclined"

    Sheets(1).Select      'ActiveSheet.Next.Select

    Range(Cells(2, accNumCol), Cells(Rows.count, accNumCol).End(xlUp)).Copy Destination:=Sheets(2).Range("A2")

    'If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData  'clear the AutoFilter

    If ActiveSheet.AutoFilterMode Then Cells.AutoFilter  'clear the AutoFilter

    Sheets(2).Select

'    Range("B2") = "Y"

'    Range("C2") = "Y"

    lastRow = Cells(Rows.count, "A").End(xlUp).Row

''    Range("B2").AutoFill Destination:=Sheets(2).Range("B2:B" & lastRow)

''    Range("C2").AutoFill Destination:=Sheets(2).Range("C2:C" & lastRow)

    Sheets(2).Range("B2:B" & lastRow) = "unengaged_fire_Mar17"  ' "unengaged_mh_Mar17" ' "unengaged_ld_Mar17"  ' "unengaged_elt_Mar17" ' "unengaged_socialcare_Mar17"

'    Sheets(2).Range("B2:B" & lastRow) = "Y"

'    'Sheets(2).Range("C2:C" & lastRow) = "Y"

    Range("A1").Select

End Sub

'Following code jumps / goes to current week.

'assumptions: code assumes that Column A contains dates,

'a series of first day of each week (e.g.: 08-Aug-2016, 15-Aug-2016, 22-Aug-2016 and so on.)

Sub goto_curr_week()

    Dim cell As Range, _

        wcf As Range

    Dim today As Long     'must compare dates in Long otherwise problematic.

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

    For Each cell In Range("A12:A9999")

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

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

            Set wcf = cell

            Exit For

        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

'Following inserts the SubTotal() formula in current cell:

Sub InsertSubTotalOfVisibleOnlyCells()

    Dim currColLetter As String: currColLetter = ColumnNumberToLetter(ActiveCell.Column)

    Dim currRowNum As Long: currRowNum = ActiveCell.Row

    ActiveCell.Formula = "=SUBTOTAL(103," & currColLetter & "2:" & currColLetter & (currRowNum - 1) & ")"

End Sub

Sub DedupeRowsBy1PositionsPerOrganisation()

    Application.ScreenUpdating = False

    Dim r, lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim org, pos As String

    For r = lastRow To 2 Step -1 ' ActiveSheet.UsedRange.Rows.Count

        'D & K: If (Cells(r, "D") = Cells(r - 1, "D") And Cells(r, "D") <> "" And Cells(r, "K") = Cells(r - 1, "K") And Cells(r, "K") <> "") Then

        If Cells(r, "N") = Cells(r - 1, "N") Then

        'If (Cells(r, "G") = Cells(r - 1, "G") And Cells(r, "Q") = Cells(r - 1, "Q") And Cells(r, "H") <> "") Then

          If (Cells(r, "E") = Cells(r - 1, "E") And Cells(r, "E") <> "") Then

            'InStr(1, "Hello World", "Hello W") = 1

            'Cells(r, "A") = ""

            Rows(r).EntireRow.Delete

            'Rows(r).EntireRow.Hidden = True

          End If

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done..."

End Sub

'Following sub dedupes the Subscribers' list - it eliminates duplication caused by Invoice & Delivery addresses (for accounts with 2 addresses.)

'Assumptions:

'1) Data must be sorted in Acc_No's ascending order.

'2) Columns must be in following order:

'Acc_No,Full_Name,Organisation,Postown,PostCode,Country,Country_Code,Address_Type_Id,Email,Subs_Rate_Type,Master_Acc,Start_Date,End_Date,Purchase_Price,Quantity,Revenue,Title,Subs-Type,ActiveSub,Renewal,Area

Sub DedupeSubscribersWithBothInvoiceAndDeliveryAddr()   'for Emma's Geo-Split:

    Application.ScreenUpdating = False

    Dim r, lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count + 1 'Cells(Rows.Count, 1).End(xlUp).row

    Dim org, pos As String

    For r = lastRow To 2 Step -1 ' ActiveSheet.UsedRange.Rows.Count

        'Assuming Columns (in next line): A = acc_no, L & M are Start/End dates,  N = amount, and Q = title.

        If Cells(r, "A") = Cells(r - 1, "A") And Cells(r, "L") = Cells(r - 1, "L") And Cells(r, "M") = Cells(r - 1, "M") And Cells(r, "N") = Cells(r - 1, "N") And Cells(r, "Q") = Cells(r - 1, "Q") Then

            'removing Invoice Addr (keeping Delevery Addr) Assuming Delevery Addr is valid (should be valid as these are subscribers).

            If Cells(r, "H") = 3 Then  'AddrType: 3 is Invoice Addr.  4 is Delivery Addr.

                Rows(r).EntireRow.Delete

                'Rows(r).EntireRow.Hidden = True

            ElseIf Cells(r - 1, "H") = 3 Then

                Rows(r - 1).EntireRow.Delete

                'Rows(r - 1).EntireRow.Hidden = True

            End If

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done..."

End Sub

'''Sub DedupeRowsBySimpleNextPreviousValueComparison()

'Following sub dedupes the Address data - it eliminates duplication caused by Invoice & Delivery addresses (for accounts with 2 addresses.)

    'it deletes invoice-address only if delivery-address exists for an account.

'Assumptions:

'1) Data must be sorted in Acc_No's ascending order.

'2) Columns must be in following order:

'Acc_No_email,Full_Name,position_,department,organisation,addressline1,addressline2,addressline3,locality,county,postown,postcode,country,Area,PositionType,Subject,Interest,record_date,address_type

Sub DedupeAddressInvoiceVsDeliveryV1() 'used for Catalogue2017

    Application.ScreenUpdating = False

    Dim r, lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim org, pos As String

    For r = lastRow To 2 Step -1 ' ActiveSheet.UsedRange.Rows.Count

        'In next line: A = acc_no:

        If Cells(r, "B") = Cells(r - 1, "B") Then

            If Cells(r, "R") = Cells(r - 1, "R") Then

                If Cells(r, "U") = "" And Cells(r - 1, "U") <> "" Then

                    Rows(r).EntireRow.Delete

                ElseIf Cells(r, "U") <> "" And Cells(r - 1, "U") = "" Then

                    Rows(r - 1).EntireRow.Delete

                ElseIf (Cells(r, "U") = "" And Cells(r - 1, "U") = "") Or (Cells(r, "U") <> "" And Cells(r - 1, "U") <> "") Then

                    If Cells(r, "AC") = "3" Then

                        Rows(r).EntireRow.Delete

                    ElseIf Cells(r - 1, "AC") = "3" Then

                        Rows(r - 1).EntireRow.Delete

                    Else

                        Rows(r).EntireRow.Delete

                    End If

                End If

            End If

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done... Addresses Deduped."

End Sub

'''Sub DedupeRowsBySimpleNextPreviousValueComparison()

Sub DedupeAddressInvoiceVsDeliveryV2()

    Application.ScreenUpdating = False

    Dim r, lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count + 1 'Cells(Rows.Count, 1).End(xlUp).row

    Dim org, pos As String

    For r = lastRow To 2 Step -1

        If Cells(r, "A") = Cells(r - 1, "A") And Cells(r, "B") = Cells(r - 1, "B") Then ' And Cells(r, "M") = Cells(r - 1, "M") Then

            'InStr(1, "Hello World", "Hello W") = 1 Then

            If Cells(r, "K") = "" And Cells(r, "E") = "" Then

                'Rows(r).EntireRow.Delete

                Rows(r).EntireRow.Hidden = True

            ElseIf Cells(r - 1, "K") = "" And Cells(r - 1, "E") = "" Then

                'Rows(r - 1).EntireRow.Delete

                Rows(r - 1).EntireRow.Hidden = True

            ElseIf Cells(r, "M") = "Invoice Address" Then

                'Rows(r).EntireRow.Delete

                Rows(r).EntireRow.Hidden = True

            ElseIf Cells(r - 1, "M") = "Invoice Address" Then

                'Rows(r - 1).EntireRow.Delete

                Rows(r - 1).EntireRow.Hidden = True

            End If

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done..."

End Sub

'''Sub DedupeRowsBySimpleNextPreviousValueComparison()

Sub DedupeAddressInvoiceVsDeliveryV3()

    Application.ScreenUpdating = False

    Dim r, lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count + 1 'Cells(Rows.Count, 1).End(xlUp).row

    Dim org, pos As String

    For r = lastRow To 2 Step -1

        If Cells(r, "A") = Cells(r - 1, "A") And Cells(r, "N") = Cells(r - 1, "B") Then ' And Cells(r, "M") = Cells(r - 1, "M") Then

            'InStr(1, "Hello World", "Hello W") = 1 Then

            If Cells(r, "K") = "" And Cells(r, "E") = "" Then

                'Rows(r).EntireRow.Delete

                Rows(r).EntireRow.Hidden = True

            ElseIf Cells(r - 1, "K") = "" And Cells(r - 1, "E") = "" Then

                'Rows(r - 1).EntireRow.Delete

                Rows(r - 1).EntireRow.Hidden = True

            ElseIf Cells(r, "M") = "Invoice Address" Then

                'Rows(r).EntireRow.Delete

                Rows(r).EntireRow.Hidden = True

            ElseIf Cells(r - 1, "M") = "Invoice Address" Then

                'Rows(r - 1).EntireRow.Delete

                Rows(r - 1).EntireRow.Hidden = True

            End If

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done..."

End Sub

'To avoid "Out of subscription" error, use UBound(): (unfortunately VBA doesn't provide specific operator or function for this.)

Sub CheckIfArrayElementInitialized()

    Dim arr() As String

    arr() = Split("3-25", "-")

    If UBound(arr) = -1 Then    'array is not initialised - if not checked here Match() will return "Type mismatch" error.

    'OR

    If UBound(arr) >= 1 Then If arr(1) <> "" Then MsgBox (arr(1))  'Note: you can't use isEmpty() on array-elements.

End Function

'check if empty string: use isEmpty() to check if a variable has been assigned.

Sub CheckIfVariableAssigned()

    x = 0

    y = ""

    MsgBox "IsEmpty(x): " & IsEmpty(x) & "   IsEmpty(y): " & IsEmpty(y) 'both FALSE as they're initialised.

End Sub

Sub CheckEmptyString()

    x = ""

    If Len(Trim(x)) = 0 Then

    'If Len(Trim([A1])) = 0 Then

        MsgBox "x is empty string"

    End If

End Sub

'Following sub displays First & Last Rows of UsedRange:

Sub FirstAndLastRowsInUsedRange()

    firstRow = ActiveSheet.UsedRange.Rows        ' method-1

    firstRow = ActiveSheet.UsedRange.Rows(1).Row ' method-2

    lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row

    MsgBox firstRow & " - " & lastRow

End Sub

Sub HideMultipleRowsAtOnce()

    Range("3:3, 6:6, 8:8").EntireRow.Hidden = True      'method-1

    Rows("2:15062").EntireRow.Hidden = True             'method-2

End Sub

Sub FindInUnionedRange()

    Dim aCell, rngCols As Range

    Set rngCols = Range("B1")

    Set rngCols = Union(rngCols, Range(Cells(3, "B"), Cells(5, "b")), Range(Cells(3, "D"), Cells(5, "D")))

    rngCols.Select

    Set aCell = rngCols.Find("d")

    If Not aCell Is Nothing Then

        MsgBox ":) Found at: " & aCell.Address

        End

    Else

        MsgBox "Not found  :("

    End If

End Sub

Sub SpecialCellsTest()

    'Dim r As Variant

    Dim r As Range

    On Error Resume Next

    Set r = Range("").SpecialCells(xlBlanks)

    MsgBox (r Is Nothing)

    MsgBox TypeName(r)

    On Error GoTo 0

End Sub

'Following functions returns ColorIndex values, it iterates amongst 11 bright colours.

'Important: Before calling this/NextColourIndex() function you must call InitBrightColourIndex() or InitDarkColourIndex() sub.

Function NextColourIndex()

    Dim cidx() As Variant

    If Len(Join(BrightColourIndexes)) > 0 Then

        cidx = BrightColourIndexes

    Else

        cidx = DarkColourIndexes

    End If

    If colourIdx = 0 Or colourIdx >= UBound(cidx) Then

        colourIdx = 0

    End If

    NextColourIndex = cidx(colourIdx)

    colourIdx = colourIdx + 1

End Function

Sub InitBrightColourIndex()

    Erase BrightColourIndexes

    Erase DarkColourIndexes

    BrightColourIndexes = Array(20, 44, 36, 38, 43, 34, 46, 3, 40, 17, 22)

    colourIdx = 0

End Sub

Sub InitDarkColourIndex()

    Erase BrightColourIndexes

    Erase DarkColourIndexes

    DarkColourIndexes = Array(9, 51, 1, 21, 30, 49, 11, 52, 53, 56)

    colourIdx = 0

    'MsgBox Len(Join(DarkColourIndexes))

End Sub

'Following code deletes specified Drawing-objects on ActiveSheet

'simply assign 'strDrawingObjName2Delete' variable the Control-name you want to delete, e.g. "Check Box", "DropDown" etc.

Sub DeleteDrawingObjects()

    On Error Resume Next

    Debug.Print TypeName(ActiveSheet.DrawingObjects(1)) & VarType(ActiveSheet.DrawingObjects(1))

    If Err.Description Like "*DrawingObjects property*" Then

        MsgBox "No drawing objects found on active-sheet (No Form Controls or ActiveX Controls)"

        Debug.Print Err.Number & " - " & Err.Description & " - " & Err.Source

        Err.Clear

        Exit Sub

    End If

    On Error GoTo 0

    Dim drobj As Object

    Dim strDrawingObjName2Delete As String: strDrawingObjName2Delete = "Check Box"

    Debug.Print "drawing Object Type-name: " & ActiveSheet.DrawingObjects(1).name

    Debug.Print "drawing Object Type-code: " & VarType(drobj)

    Debug.Print strDrawingObjName2Delete; " count - Before deleting " & ActiveSheet.DrawingObjects.count

    For Each drobj In ActiveSheet.DrawingObjects

        'If drobj.Name = "ComboBox1" Then    'if exact name is known.

        If InStr(1, drobj.name, strDrawingObjName2Delete, vbTextCompare) <> 0 Then

            drobj.Delete

        End If

    Next drobj

    Debug.Print strDrawingObjName2Delete; " count - After deleting " & ActiveSheet.DrawingObjects.count

End Sub

Sub StratifyByYears()

    Dim lastRow, lastCol, r, cidx  As Integer

    'Dim colourIdx:  colourIdx = Array(20, 44, 36, 38, 43, 34, 46, 3, 40, 17, 22)

    'Call InitDarkColourIndex  'NextColourIndex  is now active and will keey returning next DARK ColorIndex.

    Call InitBrightColourIndex  'NextColourIndex  is now active and will keey returning next BRIGHT ColorIndex.

    lastRow = Cells(Rows.count, 1).End(xlUp).Row

    lastCol = Cells(ActiveSheet.UsedRange.Row, Columns.count).End(xlToLeft).Column

    cidx = NextColourIndex

    For r = 2 To lastRow

        'Debug.Print NextColourIndex

        If Not IsEmpty(Cells(r, "C")) Then

            Range(Cells(r, 1), Cells(r, lastCol)).Interior.ColorIndex = cidx

            If Year(Cells(r, "C")) <> Year(Cells(r + 1, "C")) Then

                cidx = NextColourIndex

            End If

        End If

    Next r

End Sub

'Following VBA copies the values from a column into another whilst preserving values in 2nd/target column hence only writing to Blank cells (NOT overwrite any data in target column).

Sub CopyColumnValuesOnlyInEmptyCells()

    Application.ScreenUpdating = False

    MsgBox "You will be propmeted to enter 2 Columns next." & vbNewLine & vbNewLine & "First ""FROM"" column then ""TO"" column.", vbOKOnly & vbInformation, "Next Entries"

    Dim sourceCol As String: sourceCol = GetTargetColumn()

    Dim targetCol As String: targetCol = GetTargetColumn()

    

    Dim lastRow As Long, r As Long

    lastRow = Cells(Rows.count, sourceCol).End(xlUp).Row

    For r = 1 To lastRow

        If IsEmpty(Cells(r, targetCol)) Then

            Cells(r, targetCol) = Cells(r, sourceCol)

        End If

    Next r

    Application.ScreenUpdating = True

End Sub

'Find&Replace Keys with Values (Keys-Values-pair written in column A & B): if the Key is found in a Column-D then replace it with its (corresponding) value.

'In other words, match substrings in column-D with values in column-A, if matched, replace substring in column-D with value in Column-B (corresponding to column-A).

Sub FindAndReplaceKeysWithValues()

    Dim lastRow As Long, r As Long

    lastRow = Cells(Rows.count, "A").End(xlUp).Row

    For r = 2 To lastRow

        Range("D:D").Replace What:=Cells(r, "A"), Replacement:=Cells(r, "B"), LookAt:=xlPart, MatchCase:=False

        'Range("D:D").Replace What:=Cells(r, "A"), Replacement:=Cells(r, "B"), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Next r

End Sub

Sub SplitJoinFunctionsCheck()

s = "9#this#is#test"

a = Split(s, "#")

MsgBox Join(a, "#")

MsgBox TypeName(a)

End Sub

'Copy the output (without Header) in a blank sheet then run this to format, then simply copy values to the Monthly Subs Report.

Sub MonthlyReportSortBySubs()

    Dim lastRow, r As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim s As String

    Dim arrSubs() As String

    [A1:C1].Copy Destination:=[F1]

    'arrSubs() = Split("British Journal of Family Medicine,Care Knowledge,English Teaching Professional,Fire Magazine,GM Journal,Journal of Family Health,Learning Disability Today,Mental Health Today Magazine,Modern English Teacher", ",")

    arrSubs() = Split("British Journal of Family Medicine,Care Knowledge,English Teaching Professional,Fire Magazine,GM Journal,Journal of Family Health,Modern English Teacher", ",")

    'arrSubs() = Split("British Journal of Family Medicine,English Teaching Professional,Fire Magazine,GM Journal,Journal of Family Health,Modern English Teacher", ",") 'without CK

    Cells(1, 6).Select

  'cind = 5

    For Each subName In arrSubs

        ActiveCell.Offset(1, 0).Select

        ActiveCell = subName

    'cind = cind + 1

        For r = 1 To lastRow

            'Cells(r, "A").Interior.ColorIndex = cind

            s = Cells(r, "A")

            If InStr(1, s, subName, 1) <> 0 Then

                ActiveCell.Offset(0, 1) = Cells(r, "B")

                ActiveCell.Offset(0, 2) = Cells(r, "C")

                Exit For

            Else

                ActiveCell.Offset(0, 1) = 0

                ActiveCell.Offset(0, 2) = 0

            End If

        Next r

    Next

    ActiveCell.Offset(1, 0).Select

    'ActiveCell.Interior.ColorIndex = 37

    ActiveCell = "Total (All Subs)"

    ActiveCell.Offset(0, 1).Select

    'ActiveCell.Interior.ColorIndex = 37

    'ActiveCell.Formula = "=sum(range(cells(1,activecells.column),cells(activecell.offset(-1,0),activecells.column) ))"

    'ActiveCell.Formula = "=sum(E2:E8)"

    ActiveCell.Offset(-1, 0).Select

    Set rng = Range(ActiveCell.Address & ":" & ActiveCell.End(xlUp).Offset(1, 0).Address)

    ActiveCell.Offset(1, 0) = Application.WorksheetFunction.Sum(rng)

    'ActiveCell.Formula = "=sum(E2:E8)"

    ActiveCell.Offset(0, 1).Select

    Set rng2 = Range(ActiveCell.Address & ":" & ActiveCell.End(xlUp).Offset(1, 0).Address)

    ActiveCell.Offset(1, 0) = Application.WorksheetFunction.Sum(rng2)

    rng.Select

    rng.Copy

End Sub

'Copy the output (without Header) in a blank sheet then run this to format, then simply copy values to the Monthly Subs Report.

Sub MonthlyReportSortBySubs_WithLDMH()

    Dim lastRow, r As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim s As String

    Dim arrSubs() As String

    arrSubs() = Split("British Journal of Family Medicine,Care Knowledge,English Teaching Professional,Fire Magazine,GM Journal,Journal of Family Health,Learning Disability Today,Mental Health Today Magazine,Modern English Teacher", ",")

    'arrSubs() = Split("British Journal of Family Medicine,Care Knowledge,English Teaching Professional,Fire Magazine,GM Journal,Journal of Family Health,Modern English Teacher", ",")

    Cells(1, 6).Select

  'cind = 5

    For Each subName In arrSubs

        ActiveCell.Offset(1, 0).Select

        ActiveCell = subName

    'cind = cind + 1

        For r = 1 To lastRow

            'Cells(r, "A").Interior.ColorIndex = cind

            s = Cells(r, "A")

            If InStr(1, s, subName, 1) <> 0 Then

                ActiveCell.Offset(0, 1) = Cells(r, "B")

                Exit For

            Else

                ActiveCell.Offset(0, 1) = 0

            End If

        Next r

    Next

    ActiveCell.Offset(1, 0).Select

    ActiveCell.Interior.ColorIndex = 37

    ActiveCell = "Total (All Subs)"

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Interior.ColorIndex = 37

    'ActiveCell.Formula = "=sum(range(cells(1,activecells.column),cells(activecell.offset(-1,0),activecells.column) ))"

    ActiveCell.Formula = "=sum(G2:G10)"

    'ActiveCell.Formula = "=sum(G2:G8)"

    Range("G2:G10").Select

    Range("G2:G10").Copy

End Sub

'Following sub separates the Firstnames & LastNames

'requires: 2 emtpy columns on the right of "FullName" column.

Sub ExtractFirstName()

    Dim titles() As String

    Dim pos As Integer

    Dim firstName As String

    Dim surName As String

    Dim tmpArr() As String

    titles() = Split("Miss, Ms, Mr, Mrs, Sir, Lady, Madam, Dr, Lord, Miss., Ms., Mr., Mrs., Sir., Lady., Madam., Dr., Lord., FAO, FAO:", ", ")

    For r = 2 To 3568

        If Not IsEmpty(Cells(r, "C")) Then

            tmpArr() = Split(Cells(r, "C"), " ")

            

            'Firstname processing:

            firstName = tmpArr(0)

            If (IsInArray(firstName, titles)) Then

                firstName = Split(Cells(r, "C"), " ")(1)

            End If

            Cells(r, "D") = firstName

            

'            'Surname processing:

'            pos = InStr(Cells(r, "C"), firstName)

'            pos = pos + Len(firstName)

'            surName = Mid(Cells(r, "C"), pos)

            surName = tmpArr(UBound(tmpArr))

            Cells(r, "E") = surName

        End If

    Next r

End Sub

'Following reads strings in column-A, extracts all substrings enclosed within % and (if found) writes

'   in next column-B, if multiple instances are found splits/writes them into  B, C, D... columns.

'requires: data in column A

Sub ExtractSubstring()

    '=MID(A1,find("%"),1)

    Dim lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim pos, posEnd As Integer: pos = 0

    Dim count, c As Integer: count = 0

    Dim cVal, wrd As String

    For r = 1 To lastRow

        cVal = Cells(r, "A")

        If Not IsEmpty(cVal) Then

            c = 2

            Do

                count = count + 1

                pos = InStr(pos + 1, cVal, "%", 1)

                If pos = 0 Then Exit Do

                posEnd = InStr(pos + 1, cVal, "%", 1)

                wrd = Mid(cVal, pos + 1, (posEnd - (pos + 1)))

                Cells(r, c) = wrd

                c = c + 1

                pos = posEnd

            Loop While pos

        End If

    Next r

    MsgBox count

End Sub

'Following code sorts the UsedRange by font-colour.

Sub SortByColour()

    Application.FindFormat.Font.fontStyle = "Bold"

    lastRow = 9000

    Set aCell = Range("A2:A" & lastRow).Find(What:="", SearchFormat:=True)

    MsgBox aCell.Address

    If Not aCell Is Nothing Then

        aCell.Select

    End If

    ActiveSheet.Sort.SortFields.Clear

    'ActiveSheet.UsedRange.Sort Key1:=Cells(1, lastCol), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

    lastCol = 8

    'ActiveSheet.UsedRange.Sort Key1:=ActiveCell.Font.ColorIndex, Order1:=xlAscending, MatchCase:=False, Header:=xlYes

    

ActiveSheet.Sort.SortFields.Add(ActiveCell, xlSortOnFontColor, xlAscending, xlSortTextAsNumbers).SortOnValue.Color = RGB(255, 0, 0)

    With ActiveSheet.Sort

        .SetRange ActiveSheet.UsedRange

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

'ActiveSheet.Sort.SortFields.Add(Range("A987"), xlSortOnFontColor, xlAscending, , xlSortTextAsNumbers).SortOnValue.Color = RGB(255, 0, 0)

'    With ActiveWorkbook.Worksheets("Sheet1 (2)").Sort

'        .SetRange Range("A2:D12700")

'        .Header = xlNo

'        .MatchCase = False

'        .Orientation = xlTopToBottom

'        .SortMethod = xlPinYin

'        .Apply

'    End With

    Range("A1").Select

End Sub

'Following combines / concatenates the values in the passed range into one single String value and returns it.

'USAGE: =ColumnsToText(Range("A1:F1"))

'       =ColumnsToText(Range("A1:F1", "#"))  '2nd arg: to force "#" as delimiter.

Public Function ColumnsToText(rng As Range, Optional DelimitBy As String = " ") As String

    Dim var As Variant: var = rng

    Dim strArr() As String

    For c = 1 To UBound(var, 2) '2 = Second array dimension is columns.

        ReDim Preserve strArr(c) As String

        strArr(c) = CStr(var(1, c))

    Next c

    Debug.Print Join(strArr, DelimitBy)

    ColumnsToText = Join(strArr, DelimitBy)

End Function

'Following concatenates all left cells and inserts this concatenated string into ActiveCell:

Sub ConcatenateLeftCells()

    r = ActiveCell.Row

    c = ActiveCell.Column

    Dim rng As Range: Set rng = Range(Cells(r, 1), Cells(r, c))

    Dim delimiter As String: delimiter = ""

    ActiveCell = ColumnsToText(rng, delimiter)

End Sub

'Following concatenates all the left-cells-values into the ActiveCell by inserting Concatenate() formula, it also auto-fills the formula in all cells below the ActiveCell:

'It basically inserts the formula in the ActiveCell then does the same until the last row:

Sub ConcatenateLeftCellsTillLastRow()

    r = ActiveCell.Row

    c = ActiveCell.Column

    Dim strConcat As String: strConcat = "=Concatenate("

    For col = 1 To c - 1

        strConcat = strConcat & Chr(col + 64) & r & ","

    Next col

    strConcat = Left(strConcat, Len(strConcat) - 1) & ")"

    ActiveCell.Formula = strConcat

    Dim lastRow As Long: lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    Dim fillDest As Range

    Set fillDest = Range(Cells(r, c), Cells(lastRow, c))

    ActiveCell.AutoFill Destination:=fillDest

End Sub

'Following combines a vertical column's values of CURRENT-COLUMN into one cell as comma separated values

    'which can be used in a WHERE clause of a SQL query.

Sub ColumnToCommaSeparatedValuesIntoNextColumn()

    Dim r As Integer: r = ActiveCell.Row()

    Dim c As Integer: c = ActiveCell.Column()

    'Dim colCount As Integer: colCount = ActiveSheet.Cells(r, Columns.count).End(xlToLeft).Column

    Dim rowCount As Integer: rowCount = Cells(Rows.count, 1).End(xlUp).Row

    

    If rowCount <= 1 Then

        MsgBox "No value found in that row." & vbNewLine & vbNewLine & "Ensure that cursor is placed on the same row (where columns values need to be compiled as Comma-separated-Values.", vbCritical, "Unexpected error"

        End

    End If

    Dim inQuotes As Boolean: inQuote = False

    Dim ans As String

    ans = MsgBox("Would you like values in quotes?", vbYesNoCancel, "Values in Quotes")

    If ans = vbYes Then

        inQuote = True

    ElseIf ans = vbNo Then

        inQuote = False

    Else

        End

    End If

    For i = 1 To rowCount

        cellValue = Cells(i, c).Value

        If Len(cellValue) > 0 Then

            If inQuote Then

                'strCommaList = strCommaList & ",''" & cellValue & "''"    'with ''Double-apostrophes'' (words enclosed within 'apostrophe')

                strCommaList = strCommaList & ",'" & cellValue & "'"    'with 'apostrophe' (words enclosed within 'apostrophe')

            Else

                strCommaList = strCommaList & "," & cellValue           'withOUT enclosing 'apostrophes'

            End If

            'Debug.Print strCommaList

            ''Join(arr, ",") join() doesn't work with 2d arrays.

        End If

    Next

    'strCommaList = "'" & Right(strCommaList, Len(strCommaList) - 1)

    Debug.Print strCommaList

    Cells(c, c + 2) = strCommaList

End Sub

'Following combines a vertical column's values into into one cell as comma separated values,

    'which can be used in a WHERE clause of a SQL query.

Sub ColumnToCommaSeparatedValuesIntoNextColumn__OLD()

    Dim inQuotes As Boolean: inQuote = False

    'Dim inQuotes As Boolean: inQuote = True

    Dim ans As String

    ans = MsgBox("Would you like values in quotes?", vbYesNo, "Values in Quotes")

    If ans = vbYes Then

        inQuote = True

    Else

        inQuote = False

    End If

    Dim strCol As String: strCol = GetTargetColumn()

    If strCol = "" Then

        strCol = "A"

        'End

    End If

    Dim firstRow As Double: firstRow = 1

    If IsEmpty(Cells(1, 1)) Then    'just in case if first few cells are empty.

        firstRow = Cells(1, strCol).End(xlDown).Row

    End If

    Dim lastRow As Double: lastRow = Cells(Rows.count, strCol).End(xlUp).Row

    Dim rng As Range: Set rng = Range(firstRow & ":" & lastRow)

    Dim arr As Variant: arr = rng

    Dim strCommaList As String

    'Dim intCol As Integer: intCol = Range(strCol & 1).Column

    For r = 1 To UBound(arr, 1) ' First array dimension is a row.

        If Len(arr(r, 1)) > 0 Then

            If inQuote Then

                strCommaList = strCommaList & ",'" & arr(r, 1) & "'"    'with apostrophe (words enclosed within 'apostrophe')

            Else

                strCommaList = strCommaList & "," & arr(r, 1)  'withOUT enclosing 'apostrophes'

            End If

            'Debug.Print strCommaList

            ''Join(arr, ",") join() doesn't work with 2d arrays.

        End If

    Next r

    strCommaList = "'" & Right(strCommaList, Len(strCommaList) - 1)

    Debug.Print strCommaList

    rng.Cells(1, 3) = strCommaList

    'arr = Application.Transpose(Application.Transpose(rng.Value))

    'Join(var, ",")

End Sub

Sub DeleteIfNextCellIsEmpty()

    Application.ScreenUpdating = False

    Dim r, lastRow As Long

    'lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    lastRow = 4023

    Dim org, pos As String

    For r = lastRow To 2 Step -1

        'If (Cells(r, "G") = Cells(r - 1, "G") And Cells(r, "Q") = Cells(r - 1, "Q") And Cells(r, "H") <> "") Then

        If IsEmpty(Cells(r, "J")) Then

        'InStr(1, "Hello World", "Hello W") = 1

            Cells(r, "h") = ""

            'Rows(r).EntireRow.Delete

            'Rows(r).EntireRow.Hidden = True

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done..."

End Sub

'Following is very useful for removing duplications from Address-Labels:

Sub DeleteIfNextCellHasValue()

    Application.ScreenUpdating = False

    Dim r, lastRow, cnt As Long

    Dim strCol As String: strCol = GetTargetColumn()

    strCol = Trim(strCol)

    If strCol = "" Then

        End

    End If

    If UCase(strCol) = "A" Then

        MsgBox "Column-A is the first column - there is no column on its left to compare it with." & vbNewLine & vbNewLine & "Enter a column-letter starting from Column-B onwards."

        End

    End If

    

    'lastRow = ActiveSheet.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    lastRow = 4009

    Dim org, pos As String

    For r = lastRow To 2 Step -1

        'If (Cells(r, "G") = Cells(r - 1, "G") And Cells(r, "Q") = Cells(r - 1, "Q") And Cells(r, "H") <> "") Then

        'If IsEmpty(Cells(r, "J")) Then

        'InStr(1, "Hello World", "Hello W") = 1

        'If InStr(1, Cells(r, strCol), Cells(r, Asc(strCol) - 1)) = 1 Then

        'MsgBox ("*" & Cells(r, strCol) & "*" & Cells(r, Chr(Asc(strCol) - 1))) & " --- " & ("*" & Cells(r, strCol) & "*" Like Cells(r, Chr(Asc(strCol) - 1)))

        'MsgBox ("*" & Cells(r, strCol) & "*" & Cells(r, Chr(Asc(strCol) - 1))) & " --- " & (Cells(r, Chr(Asc(strCol) - 1)) Like "*" & Cells(r, strCol) & "*")

        'If (Cells(r, Chr(Asc(strCol) - 1)) Like "*" & Cells(r, strCol) & "*") Then ' Or (Cells(r, Chr(Asc(strCol) - 2)) Like "*" & Cells(r, strCol) & "*") Then ' Or (Cells(r, Chr(Asc(strCol) - 3)) Like "*" & Cells(r, strCol) & "*") Then ' Or (Cells(r, Chr(Asc(strCol) - 4)) Like "*" & Cells(r, strCol) & "*")) Then

        If Cells(r, strCol) <> "" And Cells(r, Chr(Asc(strCol) - 1)) = Cells(r, strCol) Then

'            MsgBox "Match found."

'            End

Debug.Print Cells(r, strCol) & " = " & Cells(r, Chr(Asc(strCol) - 1))

            Cells(r, strCol) = ""

            cnt = cnt + 1

            'Rows(r).EntireRow.Delete

            'Rows(r).EntireRow.Hidden = True

        End If

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done... Total replacements: " & cnt

End Sub

Sub CopyXlsbFileIntoUsersAppDataFolder()

'usrDesktopFolder = CreateObject("WScript.Shell").specialfolders("Desktop")  'to get user's Desktop folder as String

'MsgBox usrDesktopFolder

'End

   'Creating folder (if doesn't exist):

    Dim fPath As String

    Set objWShell = CreateObject("WScript.Shell")

    appData = objWShell.expandEnvironmentStrings("%APPDATA%")

    'fPath = CurDir()   'CurDir() returns- C:\Users\eddie.shrivastava\Documents

    fPath = appData & "\Microsoft\Excel\XLSTART2"

    Dim fName As String:  fName = "XLSTART2"

    CreateFolderCheckIfNotExists (fPath)

    

   'Copying file:

    Dim fs As Object

    Dim sourcePathFile As String, targetPathFile As String

    'sourcePathFile = CurDir() & "\Doc2.docx"

    sourcePathFile = "\\slgpipav01\sgpdata\Data Reports\PavilionVBAUtilities\PavilionVBAUtilities.xlsb"

    targetPathFile = fPath & "\PavilionVBAUtilities.xlsb"

    Set fs = CreateObject("Scripting.FileSystemObject")

    fs.CopyFile sourcePathFile, targetPathFile

    Set fs = Nothing

End Sub

'following function takes full path+filename for a folder creation,

'if folder doesn't exists - it creates a new folder and returns True, otherwise returns False.

Function CreateFolderCheckIfNotExists(folderNameWithFullPath As String)

    'usrDesktopFolder = CreateObject("WScript.Shell").specialfolders("Desktop")  'to get user's Desktop folder as String

    'If Dir("C:\_Development\Deleteme", vbDirectory) = "" Then

    '    MkDir Path:="C:\_Development\Deleteme"

    If Dir(folderNameWithFullPath, vbDirectory) = "" Then

        MkDir Path:=folderNameWithFullPath

        CreateFolderCheckIfNotExists = True

    Else

        CreateFolderCheckIfNotExists = False

    End If

End Function

'Following code adds a column containing percentages of bounced emails.

'run this from within the "Weekly email summary.csv" file sent by Communigator.

'Assumptions: new column is added at column "F" assuming that preceding two columns (D & E) contain number of sent & undelivered emails.

Sub AddBouncedEmailsPercentColumn()

    If (ActiveWorkbook.name Like "Weekly email summary*" Or ActiveWorkbook.name Like "Monthly Report*") Then  ' ActiveSheet.name

        Dim lastRow As Double: lastRow = Cells(Rows.count, 1).End(xlUp).Row

        Columns("F:F").Insert Shift:=xlToRight

        Columns("F:F").NumberFormat = "0.00%"

        Range("F1") = "Undel%"

        Range("F2").FormulaR1C1 = "=RC[-1]/RC[-2]"

        Range("F2").AutoFill Destination:=Range("F2:F" & lastRow)

        ActiveSheet.UsedRange.Sort Key1:=Range("F2"), Order1:=xlAscending, MatchCase:=False, Header:=xlYes

    Else

        MsgBox "This macro must be executed from within the 'Weekly email summary.csv' file (sent by Communigator)."

    End If

    Call FormatEdTableWithHeader

    Call ApplyColourScaleOnColumn("F")

End Sub

'Following brings the value of last (staggered) column to the first column-A.

'in a non-structured data, this is very useful if you want PostCode written in right-most cells to one column.

Sub BringLastStaggeredColumnsValuesToFirstColumnA()

    Application.ScreenUpdating = False

    [A1].EntireColumn.Insert

    Dim lastRow, lastCol As Long, r As Long

    lastRow = Cells(Rows.count, 2).End(xlUp).Row

    For r = 1 To lastRow

        lastCol = Cells(r, Columns.count).End(xlToLeft).Column

        tVal = Trim(Cells(r, lastCol).Value)

        Cells(r, 1) = tVal

    Next r

    Application.ScreenUpdating = True

End Sub

'BEST WAY TO FIND LAST ROW & LAST COLUMN (recommended by MSDN):

'Usage: int LastRow = LastRow(ActiveSheet)

Function GetLastRow(Sh As Worksheet)

    On Error Resume Next

    GetLastRow = Sh.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

    'LastRow = sh.UsedRange.SpecialCells(xlCellTypeLastCell).row

    'LastRow = sh.Cells.Find(What:="*", _

                            After:=sh.Range("A1"), _

                            Lookat:=xlPart, _

                            LookIn:=xlFormulas, _

                            SearchOrder:=xlByRows, _

                            SearchDirection:=xlPrevious, _

                            MatchCase:=False).row

    On Error GoTo 0

End Function

'Usage: int LastCol = LastCol (<Sheet>)

Function GetLastCol(Sh As Worksheet)

    On Error Resume Next

    'LastCol = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Column

    GetLastCol = Sh.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column

    'LastCol = sh.Cells.Find(What:="*", _

                            After:=sh.Range("A1"), _

                            Lookat:=xlPart, _

                            LookIn:=xlFormulas, _

                            SearchOrder:=xlByColumns, _

                            SearchDirection:=xlPrevious, _

                            MatchCase:=False).Column

    On Error GoTo 0

End Function

'Consolidating data from multiple sheets into one sheet:

Sub CopyRangeFromMultiWorksheets()

    Dim Sh As Worksheet

    Dim DestSh As Worksheet

    Dim Last As Long

    Dim CopyRng As Range

    With Application

        .ScreenUpdating = False

        .EnableEvents = False

    End With

    ' Delete the summary sheet if it exists.

    Application.DisplayAlerts = False

    On Error Resume Next

    ActiveWorkbook.Worksheets("MergeDataSheet").Delete

    On Error GoTo 0

    Application.DisplayAlerts = True

    ' Add a new summary worksheet.

    Set DestSh = ActiveWorkbook.Worksheets.Add

    DestSh.name = "MergedDataSheet"

    ' Loop through all worksheets and copy the data to the

    ' summary worksheet.

    For Each Sh In ActiveWorkbook.Worksheets

        If Sh.name <> DestSh.name Then

            ' Find the last row with data on the summary worksheet.

            Last = GetLastRow(DestSh)

            ' Specify the range to place the data.

            Set CopyRng = Sh.Range("A2:" & Sh.UsedRange.SpecialCells(xlCellTypeLastCell).Address)

        

            ' Test to see whether there are enough rows in the summary worksheet to copy all the data.

            If Last + CopyRng.Rows.count > DestSh.Rows.count Then

                MsgBox "There are not enough rows in the destitaion worksheet to place all the data."

                GoTo ExitTheSub

            End If

            ' This statement copy-pastes values from each worksheet:

            CopyRng.Copy Destination:=DestSh.Range("A" & (Last + 1))

            ' Optional: This statement will copy the sheet

            ' name in the H column.

            'DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If

    Next

ExitTheSub:

    Application.GoTo DestSh.Cells(1)

    ' AutoFit the column width in the summary sheet.

    DestSh.Columns.AutoFit

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

    End With

End Sub

'following applies visualisation based on value-range on pased column (using Colour-Scale)

'Usage: ApplyColourScaleOnColumn ("D")

Sub ApplyColourScaleOnColumn(c As String)

    Dim rng As Range: Set rng = Columns(c & ":" & c)

    rng.FormatConditions.AddColorScale ColorScaleType:=3

    rng.FormatConditions(rng.FormatConditions.count).SetFirstPriority

    rng.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue

    With rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor

        .Color = 8109667

        .TintAndShade = 0

    End With

    rng.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile

    rng.FormatConditions(1).ColorScaleCriteria(2).Value = 50

    With rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor

        .Color = 8711167

        .TintAndShade = 0

    End With

    rng.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue

    With rng.FormatConditions(1).ColorScaleCriteria(3).FormatColor

        .Color = 7039480

        .TintAndShade = 0

    End With

    Range(c & "1").Select

End Sub

'Following splits the rows in group of 1000 rows and exports them in individual CSV files:

Sub SplitRowsIn1000sAndExportAsCSV()

  'CopyHeaderRowToNewSheet:

    Dim RowsRng As String

    Dim SourceSh, DestSh As Worksheet: Set SourceSh = ActiveSheet

    'Dim lastRow, r As Long: lastRow = SourceSh.UsedRange.Rows.count 'Cells(Rows.Count, 1).End(xlUp).row

    'ActiveSheet.UsedRange 'works if executed in the Immediate window to get rid of empty-range but not in VBA Sub.

    Dim lastRow, r As Long: lastRow = SourceSh.UsedRange.SpecialCells(11).Row

    Dim lastCol, c As Integer: lastCol = SourceSh.UsedRange.SpecialCells(11).Column

    c = SourceSh.Cells(1, SourceSh.Columns.count).End(xlToLeft).Column

    SourceSh.Columns(ColumnNumberToLetter(c + 1) & ":" & ColumnNumberToLetter(lastCol + 1)).Delete

'    MsgBox SourceSh.Rows(lastRow + 1 & ":" & lastRow + 1000).Address

'    SourceSh.Rows(lastRow + 1 & ":" & lastRow + 1000).Delete 'instead-accurately formed the RowsRng below using: ElseIf (r + 999) >= lastRow

    For r = 1 To (lastRow) Step 1000

        Set DestSh = ActiveWorkbook.Worksheets.Add

        SourceSh.Rows(1).Copy Destination:=DestSh.Rows(1)

        If r = 1 Then

            RowsRng = "2:1000"

            'Set RowsRng = Range(Rows(2), Rows(1000))

        ElseIf (r + 999) >= lastRow Then

            RowsRng = r & ":" & lastRow

        Else

            RowsRng = r & ":" & (r + 999)

            'Set RowsRng = Range(Rows(r), Rows(r + 999))

        End If

        Debug.Print DestSh.name & "   -   " & r & "   -   " & RowsRng

        SourceSh.Range(RowsRng).Copy Destination:=DestSh.Range("A2")

        DestSh.Select

        Call ExportCurrSheetAsCSV_WithoutPrompt(ActiveWorkbook.Path)

    Next r

    SourceSh.Select

    Call DeleteAllButActiveSheet

End Sub

'Following code saves the current worksheet as CSV file with same name as current sheet-name in the current folder.

Sub ExportCurrSheetAsCSV_WithoutPrompt(wBookPath As String)

     wBookName = ActiveWorkbook.name & " - " & Replace(ActiveSheet.name, "Sheet", "Batch") & ".csv"

     ActiveSheet.Copy

     ActiveWorkbook.SaveAs fileName:=wBookPath & "\" & wBookName, FileFormat:=xlCSV, CreateBackup:=False

     ActiveWorkbook.Close False

     'ThisWorkbook.Activate

     'MsgBox "Sheet exported as: """ & wBookName & """" & vbNewLine & vbNewLine & "Saved under: " & wBookPath

End Sub

Sub SimpleRangeCheck()

    For r = 1 To 4005 Step 1000

        If r > 2000 Then End

        Debug.Print r & "   -   " & r + 999

    Next r

End Sub

'Following simply selects a range of rows:

Sub Select1000Rows()

    'Range(Rows(2), Rows(1000)).Select

    'Range(Rows(1001), Rows(2000)).Select

    'Range(Rows(2001), Rows(3000)).Select

    'Range(Rows(3001), Rows(4000)).Select

    'Range(Rows(4001), Rows(5000)).Select

    Range(Rows(5001), Rows(6000)).Select

    'Range(Rows(6001), Rows(7000)).Select

    'Range(Rows(7001), Rows(8000)).Select

    'Range(Rows(8001), Rows(9200)).Select

    'Range(Rows(9201), Rows(10495)).Select

    'Call Split1000RecordsExportAsCSV

End Sub

'Formats the Spec Spreadsheet to make it more readable - for temporary use (don't save it)

Sub SpecFormatTmp()

    'Application.DisplayAlerts = False  'resets & sets the Text-Wrap to True - spoiling manual row-height.

    Dim found As Boolean: found = False

    Dim filterRow As Long

    For Each ws In Worksheets

      If InStr(1, ws.name, "Data Mapping", vbTextCompare) Then

        found = True

      End If

    Next ws

    'If (ActiveWorkbook.name Like "Weekly email summary*" Or ActiveWorkbook.name Like "Monthly Report*") Then  ' ActiveSheet.name

    If Not found Then

        MsgBox "Wrong workbook.  This macro must be executed from within a Spec - containing a sheet called ""Data Mapping""."

        End

    End If

    Sheets("Data Mapping").Select

    Call CreateCopyOfCurrentSheet

    'ActiveWindow.SmallScroll Down:=-30

    'Range("DataMapping[[#Headers],[Target Table]]").Select

    

    'Removing AutoFilter Dropdowns:

    Cells(Rows.count, 1).End(xlUp).Select   'need to be within the filtered-range, otherwise ListObjects(1) will be null.

    If (ActiveSheet.ListObjects(1).ShowAutoFilter = True) Then

       'ActiveSheet.ListObjects(1).ShowAutoFilter = False

       'ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeLastCell).AutoFilter    'Same as above removes AutoFilter.

       'iif(ActiveSheet.AutoFilter.Range.Rows(1).row<=0, filterRow=1, (filterRow = ActiveSheet.AutoFilter.Range.Rows(1).row))

        If (ActiveSheet.AutoFilter.Range.Rows(1).Row <= 0) Then

            filterRow = 1

        Else

            filterRow = ActiveSheet.AutoFilter.Range.Rows(1).Row

        End If

        'filterRow = ActiveSheet.UsedRange.Rows(1).row

        Cells(filterRow, 1).AutoFilter

        If filterRow > 1 Then

           Rows(1 & ":" & (filterRow - 1)).Hidden = True

        End If

    End If

    

    'Cells.WrapText = False

    Columns("B:B").ColumnWidth = 14

    Columns("C:C").ColumnWidth = 2

    Columns("G:G").ColumnWidth = 2

    With ActiveWindow

        .FreezePanes = False

        .SplitColumn = 0

        .SplitRow = 1

        '.SplitRow = filterRow

        .FreezePanes = True

    End With

    Cells(Rows.count, ActiveSheet.UsedRange.SpecialCells(11).Column).End(xlUp).AutoFilter  'turning on AutoFilter on visible cells.

    Cells(2, ActiveSheet.UsedRange.SpecialCells(11).Column).End(xlDown).Offset(0, -2).Select

    'Cells(filterRow, Columns.count).End(xlToLeft).Offset(0, -2).Select

    'turning on the AutoFilter:

    'ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).AutoFilter  'turning on AutoFilter on visible cells.

    'CommandBars.ExecuteMso "HideRibbon"    'use DisplayFullScreen instead.

    'Application.DisplayAlerts = True  'resets & sets the Text-Wrap to True - spoiling manual row-height.

    SetFullScreen (True)

End Sub

'Looks up and populates (if found) the Use-Case numbers into a newly inserted column 'B' within 'DDL Script' sheet:

Sub GetSpecId()

    'Application.DisplayAlerts = False  'resets & sets the Text-Wrap to True - spoiling manual row-height.

    Dim found1 As Boolean: found1 = False

    Dim found2 As Boolean: found2 = False

    For Each ws In Worksheets

      If InStr(1, ws.name, "DDL Scripts", vbTextCompare) Then

        found1 = True

      End If

      If InStr(1, ws.name, "Detailed Use Cases", vbTextCompare) Then

        found2 = True

      End If

    Next ws

    If Not (found1 And found2) Then

        MsgBox "Wrong workbook.  This macro must be executed from within a Spec - containing a 2 sheets called ""DDL Scripts"" & ""Detailed Use Cases""."

        End

    End If

    Sheets("DDL Scripts").Select

    Call CreateCopyOfCurrentSheet

    

    Dim lastRow As Long: lastRow = Cells(Rows.count, 1).End(xlUp).Row

    [B1].EntireColumn.Insert

    [B1].Value = "Spec-ID"

    With Sheets("Detailed Use Cases")

        Set rng = .Range("B1:B" & .Cells(Rows.count, 2).End(xlUp).Row)

    End With

    For r = 2 To lastRow

        If Not IsError(Application.Match(Cells(r, "A"), rng, 0)) Then

            TargetRow = Application.Match(Cells(r, "A"), rng, 0)

            Cells(r, "B") = Sheets("Detailed Use Cases").Cells(TargetRow, "C").Value

        End If

    Next r

    '[A1].Select

    'Application.DisplayAlerts = True  'resets & sets the Text-Wrap to True - spoiling manual row-height.

    SetFullScreen (True)

End Sub

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

'Written by:    Eddie Kumar Shrivastava

'Main Method(s):Sub NonStandardCharactersCheckInSheet(), NonStandardCharactersCheckInSpecifiedColumn()

'Description:   Utility to check (highlight & list) the cells containing any non-standard characters in sheet.

'Date Created:  20-10-2017

'Date Modified: 23-10-2017

'Version:   1.1

'Version info/Change Log:

'   - Added feature to highlight individual character (alogn with the entire cell-backgroud)

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

'Following sub finds & lists the cells containing any non-standard (often problematic) characters such as "TeX's Roman Fonts"

    'in the current worksheet, the code can also highlight and bring these cells on top (of sheet) if required.

Sub NonStandardCharactersCheckInSheet()  'Sub SpotDodgyCharsInSheet()

    answerHighlight = MsgBox("Would you like to highlight cells containing non-standard characters?", vbYesNoCancel + vbQuestion, "Create Copy of Sheet & Highlight Content?")

    If answerHighlight = vbCancel Then

        End

    ElseIf answerHighlight = vbYes Then

        Call CreateCopyOfCurrentSheet

    End If

    TurnOffOtherExcelActivities (True)

    Application.DisplayStatusBar = True

    Application.ScreenUpdating = True

    GetExecutionDuration_TurnOnTimer (True)

    On Error GoTo 0

    DoEvents

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    re.Pattern = "[^\w\s\.\,\*\+\-\?\\\|\(\)\[\]\{\}\^\$""#~@;:!`¬<>-€“”‘'’†‡•¦&£%/]+"

    Dim lineNums As String: lineNums = ""

    Dim found As Boolean: found = False

    endCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column

    For c = 1 To endCol

        Application.StatusBar = "Checking " & c & " of " & endCol & " | " & "PLEASE WAIT!!!    " & Int(c * 100 / endCol) & "% Completed"

        strCol = ColumnNumberToLetter(c)

        lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row

        For r = 1 To lastRow

            If re.test(Cells(r, strCol)) Then

                found = True

                lineNums = lineNums & strCol & r & ", "

                If answerHighlight = vbYes Then

                    Cells(r, strCol).Interior.Color = RGB(240, 230, 255)    'BG highlight

                    'Cells(r, strCol).Font.ColorIndex = 3                   'FG highlight

                    For i = 1 To Len(Cells(r, strCol))                      'Pin-point char(s)

                        With Cells(r, strCol).Characters(i, 1)

                          If re.test(.text) Then

                              .Font.ColorIndex = 3     'redCIndex

                              .Font.fontStyle = "Bold"

                          End If

                        End With

                    Next i

                End If

            End If

        Next r

    Next c

    Application.StatusBar = False          'Handing over statusbar's display-control back to Excel.

    TurnOffOtherExcelActivities (False)

    If found Then

        Debug.Print lineNums

        MsgBox "Following cells contain one or more non-standard characters:" _

            & vbNewLine & vbNewLine & Left(lineNums, Len(lineNums) - 2) & "." _

            & vbNewLine & vbNewLine & "The program execution took " _

            & GetExecutionDuration_TurnOnTimer(False) & " seconds.", vbOK + vbInformation, "Cell-Addresses For Content Review"

    Else

        MsgBox ("No non-standard characters found in this worksheet." _

            & vbNewLine & vbNewLine & "The program execution took " _

            & GetExecutionDuration_TurnOnTimer(False) & " seconds.")

    End If

End Sub

'Following sub finds (in specified column) and highlights (+brings on top of sheet) all possible non-standard characters such as "TeX's Roman Fonts"

Sub NonStandardCharactersCheckInSpecifiedColumn()     'SpotDodgyCharsInSpecCol()

    Dim strCol As String: strCol = GetTargetColumn()

    If strCol = "" Then

        End

    End If

    answerHighlight = MsgBox("Would you like to highlight cells containing non-standard characters & bring them on top (of sheet)?", vbYesNoCancel + vbQuestion, "Create Copy of Sheet & Highlight Content?")

    If answerHighlight = vbCancel Then

        End

    ElseIf answerHighlight = vbYes Then

        Call CreateCopyOfCurrentSheet

    End If

    TurnOffOtherExcelActivities (True)

    GetExecutionDuration_TurnOnTimer (True)

    On Error GoTo 0

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    re.Pattern = "[^\w\s\.\,\*\+\-\?\\\|\(\)\[\]\{\}\^\$""#~@;:!`¬<>-€“”‘'’†‡•¦&£%/]+"

    Dim lineNums As String: lineNums = ""

    lastRow = ActiveSheet.UsedRange.SpecialCells(11).Row

'    Columns(strCol).Interior.ColorIndex = 2

'    Columns(strCol).Font.ColorIndex = 1

    Dim found As Boolean: found = False

    For r = 1 To lastRow

        If re.test(Cells(r, strCol)) Then

            found = True

            lineNums = lineNums & (r) & ", "

            If answerHighlight = vbYes Then

                Cells(r, strCol).Interior.Color = RGB(240, 230, 255)    'BG highlight

                'Cells(r, strCol).Font.ColorIndex = 3                   'FG highlight

                For i = 1 To Len(Cells(r, strCol))                      'Pin-point char(s)

                    With Cells(r, strCol).Characters(i, 1)

                      If re.test(.text) Then

                          .Font.ColorIndex = 3     'redCIndex

                          .Font.fontStyle = "Bold"

                      End If

                    End With

                Next i

            End If

        End If

    Next r

    TurnOffOtherExcelActivities (False)

    

    If found Then

        Debug.Print lineNums

        If answerHighlight = vbNo Then

            MsgBox ("Following row-numbers contain one or more non-standard characters:" _

                & vbNewLine & vbNewLine & Left(lineNums, Len(lineNums) - 2) & "." _

                & vbNewLine & vbNewLine & "The program execution took " _

                & GetExecutionDuration_TurnOnTimer(False) & " seconds.")

        Else

            ''Following section brings the highlighted cells to top of sheet:

            ActiveSheet.Sort.SortFields.Clear

            Range(strCol & "1").Select

            ActiveSheet.Sort.SortFields.Add(ActiveCell, xlSortOnFontColor, xlAscending, xlSortTextAsNumbers).SortOnValue.ColorIndex = 3

            With ActiveSheet.Sort

                .SetRange ActiveSheet.UsedRange

                .Header = xlNo 'xlYes

                .MatchCase = False

                .Orientation = xlTopToBottom

                .SortMethod = xlPinYin

                .Apply

            End With

            Set re = Nothing

            MsgBox ("Cells containing any non-standard characterset highlighted (in the selected column) & brought to top of sheet for review." & vbNewLine & vbNewLine & "The program execution took " & GetExecutionDuration_TurnOnTimer(False) & " seconds.")

        End If

    Else

        MsgBox ("No non-standard characters found in this worksheet." _

            & vbNewLine & vbNewLine & "The program execution took " _

            & GetExecutionDuration_TurnOnTimer(False) & " seconds.")

    End If

End Sub

Sub SpotDodgyCharPositionInTargetCell()

    Dim TargetCell As Range: Set TargetCell = [C16]

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    re.Pattern = "[^\w\s\.\,\*\+\-\?\\\|\(\)\[\]\{\}\^\$""#~@;:!`¬<>-€“”‘'’†‡•¦&£%/]+"

    Dim charFound As Boolean: charFound = False

    Dim charPositions As String: charPositions = ""

  For i = 1 To Len(TargetCell)

      With TargetCell.Characters(i, 1)

        If re.test(.text) Then

            charFound = True

            charPositions = charPositions & i & ","

            .Font.ColorIndex = 3     'redCIndex

            .Font.fontStyle = "Bold"

        End If

      End With

  Next i

      If charFound Then

        Debug.Print "Dodgy characters fount at the following position(s): " & vbCrLf & Left(charPositions, Len(charPositions) - 1)

    End If

End Sub

Sub SpotDodgyCharPositionInTargetCell_CheckOnly()

    Dim TargetCell As Range: Set TargetCell = [C16]

    Dim re As Object: Set re = CreateObject("VBScript.RegExp")

    re.Pattern = "[^\w\s\.\,\*\+\-\?\\\|\(\)\[\]\{\}\^\$""#~@;:!`¬<>-€“”‘'’†‡•¦&£%/]+"

    Dim found As Boolean: found = False

    If re.test(TargetCell) Then

        found = True

    End If

    If found Then

       MsgBox "FOUND"

    Else

       MsgBox "NOT Found"

    End If

End Sub

'using Application.StatusBar to show progress of execution (instead of progress-bar)

Sub StatusBarExample()

    DoEvents 'allowing other processes (no deallock on Excel)

    'Disable Screen Updating and Events

    Application.EnableEvents = False

    Application.ScreenUpdating = False

    MsgBox ("Ready: Look at Excel's Statusbar")

    

    Dim maxLoops As Long: maxLoops = 10

    For i = 1 To maxLoops

        'Altering the Statusbar Property

        Application.StatusBar = "Executing " & i & " of " & maxLoops & " | " & "BE PATIENT!!! " & i

            'Application.Wait (Now + TimeValue("00:00:00"))  'minimum is 1 second wait - use sleep() for < 1 sec wait (e.g. for half second: Sleep(500)).

            'Application.Wait Now + 1 / (24 * 60 * 60) 'doesn't work - Overflow error.

            Sleep (200) 'sleeping for 0.2 seconds

            'Sleep() requires: Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'for Office 64 Bit

    Next i

    

    Application.StatusBar = False          'Handing over statusbar's display-control back to Excel.

    'Enable ScreenUpdating and Events

    Application.ScreenUpdating = True

    Application.EnableEvents = True

End Sub

'Following sub uses the "EdProgressBar VB-Form" and requires the next Sub ProgressBarUsingForm():

Sub ShowProgressBar()

    EdProgressBar.Show

End Sub

'to run the following sub (ProgressBarUsingForm) run the Sub ShowProgressBar() above.

Sub ProgressBarUsingForm()

    Dim maxLoops As Long: maxLoops = 10

    For i = 1 To maxLoops

        EdProgressBar.Label1.Caption = (i * 10) & "% Completed"

        EdProgressBar.bar.Width = i * 20

        Sleep (200) 'sleeping for 0.2 seconds

        'Sleep() requires: Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'for Office 64 Bit

        DoEvents

    Next i

    MsgBox ("All done...")

    EdProgressBar.Hide

End Sub

'Following 3xSubs deal with printing array-elements into Sheet:

'To print all elements in **one cell** as a single-string, convert your array into  a string (using the Join() function), then print it in a cell:

Sub PrintArrayIn1Cell(myArr As Variant, cell As Range)

    cell = Join(myArr, ",")

End Sub

Sub PrintArrayInRange(myArr As Variant, cell As Range)

    cell.Resize(UBound(myArr, 1), UBound(myArr, 2)) = myArr

End Sub

Sub TestPrintArrayIntoSheet()  '2dArrayToSheet

    Dim arr As Variant

    arr = Split("a  b  c", "  ")

    'Printing in ONE-CELL: To print all array-elements as a single string separated by comma (a,b,c):

    PrintArrayIn1Cell arr, [A1]

    

    'Printing in SEPARATE-CELLS: To print array-elements in separate cells:

    Dim arr2D As Variant

    arr2D = Application.WorksheetFunction.Transpose(arr) 'convert a 1D array into 2D array

    PrintArrayInRange arr2D, Range("B1:B3")

End Sub

Sub UnassignedVsEmptyVsNull()

    Dim MyVar                     'defaults to a Variant type

    Debug.Print IsEmpty(MyVar)    ' => True, Variant never gets auto-initialised / no default init value for Variant.

    Debug.Print IsEmpty(undeclared)    ' => True, treatead as Variant.

    

    MyVar = Null    ' Assign Null.

    Debug.Print IsEmpty(MyVar)    ' => False.

    Debug.Print IsNull(MyVar)     ' => True.

    

    MyVar = Empty                 ' explicitly assigned EMPTY.

    Debug.Print IsEmpty(MyVar)    ' => True.

    Dim i As Integer

    Debug.Print IsEmpty(i) & ", default init: " & i           ' => False, default init: 0.

    Dim str As String

    Debug.Print IsEmpty(str) & ", default init: " & str       ' => False, default init: "".

    Dim boo As Boolean

    Debug.Print IsEmpty(boo) & ", default init: " & boo       ' => False, default init: False.

End Sub

'Following (if occurred) catches specific error and gracefully handles it by printing appropriate message:

Sub ErrHandlerSimple()

    On Error GoTo ErrHandlerSimple:

    n = 1 / 0    ' cause an error

    Debug.Print "This line will never reach / NOT print as 'using On Error GoTo 0'  (instead of 'On Error GoTo Next' or 'Resume Next')"

ErrHandlerSimple:

    If Err.Number = 11 Then  'error# 11 = divide by zero

        Debug.Print "Err#11: Division by zero - error occurred."

        MsgBox "Err#11: 'Division by zero' error occurred. Application will now terminate.", vbCritical, "Unexpected error"

    Else

        MsgBox "Unexpected error occurred, see error-details in Immediate windowpane. Please contact Eddie Shrivastava to resolve.", vbCritical, "Unexpected error"

        Debug.Print Err.Number

        Debug.Print Err.Description

    End If

    On Error GoTo 0

End Sub

'Check error in Loop / Skip iteration if error occurs:

'Following handles the error in loop, if error occurs prints its details then skips the iteration.

Sub ErrHandlerInLoop()

    On Error Resume Next

    For i = 1 To 3

      Err.Clear

      n = 1 / 0    ' cause an error

      Debug.Print "all hunky dory..."

      If Err.Number = 0 Then

         'do work on success

         Debug.Print "no error"

      Else

         Debug.Print Err.Number

         Debug.Print Err.Description

         Exit For

      End If

    Next

End Sub

'Remember: you canNOT use On Error GoTo <Lable> to skip the iteration in a loop, as when you Resume, execution goes back to the line where error had occurred.

'Following depicts multiple error-occurrances and exiting error handler using Resume or Resume Next:

Sub ErrHandler()

    On Error GoTo ErrHandler1:

    n = 1 / 0    ' cause an error

    Debug.Print "all hunky dory..."

ErrHandler1:

    ' error handling code

    Debug.Print "1.error occurred"

    Debug.Print Err.Number

    Debug.Print Err.Description

    Resume Next

    

    On Error GoTo ErrHandler2:   'this will not work without resuming normal execution using "Resume Next"

    n = 1 / 0    ' cause an error AGAIN

    Debug.Print "all hunky dory..."

ErrHandler2:

    ' error handling code

    Debug.Print "2.error occurred"

    If Err.Number = 11 Then

        Debug.Print "Err#11: Division by zero - error occurred."

    Else

        MsgBox "Unexpected error occurred see error-details in Immediate windowpane.", vbCritical, "Unexpected error"

        Debug.Print Err.Number

        Debug.Print Err.Description

    End If

    On Error GoTo 0

End Sub

''Pausing Code Execution using: VBA's Wait() OR Windows' Sleep():

'Syntaxes:

'    Application.Wait (<Specific_Clock_Time>)   'available natively - no declaration required.

'    Sleep (<milliseconds>)     '   requires global declaration of Windows "kernel32" library.

'Wait(): pauses code execution until a certain time is reached. It's available natively with 1 second as minimum interval.

'Sleep(): Windows  "kernel32" has Sleep() function that pauses the entire process for a certain delay specified in milliseconds. NOTE: Freezes the entire process i.e. Excel does not respond - There is no way to stop the Sleep function.

'Unlike Application.Wait(), the Sleep() function is not available by default in VBA, and has to be imported from the kernel32 library. 'For 64 Bit procedures make sure to append the 'PtrSafe' statement.

'    #If VBA7 Then

'        Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit

'    #Else

'        Public Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) 'MS Office 32 Bit

'    #End If

    Sub SleepTest()

        GetExecutionDuration_TurnOnTimer (True) 'turn on stop-watch.

        Sleep 500                         'pause for HALF second

        MsgBox ("SleepVsWaitTest" & vbNewLine & vbNewLine & "The code took " & GetExecutionDuration_TurnOnTimer(False) & " seconds to run.") 'turn off stop-watch + return seconds.

    End Sub

    Sub WaitTest()

        GetExecutionDuration_TurnOnTimer (True) 'turn on stop-watch.

        'Application.Wait "16:30:00"                    'pause unti 4:30 pm

        Application.Wait (Now + TimeValue("0:00:01"))  'for 1 second from now

        'Application.Wait (DateAdd("s", 3, Now))        'for 3 seconds from now

        MsgBox ("SleepVsWaitTest" & vbNewLine & vbNewLine & "The code took " & GetExecutionDuration_TurnOnTimer(False) & " seconds to run.")

    End Sub

    Sub WaitTest2()

        Application.Wait (Now + #12:00:02 AM#)

        MsgBox "Waited 2 seconds"

        ''OR

        Application.Wait (Now + TimeValue("00:00:02"))

        MsgBox "Waited another 2 seconds"

    End Sub

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

Sub getPathOfCurrentFile()

    If Len(ActiveWorkbook.Path) <= 0 Then

        MsgBox "Unsaved Document!" & vbNewLine & vbNewLine & "File path/name doesn't exist as not saved yet."

    Else

        filePath = ActiveWorkbook.Path

        fileFullName = filePath & "\" & ActiveWorkbook.name

        WriteToClipboard fileFullName

        MsgBox fileFullName & vbNewLine & vbNewLine & vbNewLine & "Also copied to the Clipboard."

    End If

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

End Sub

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

''''''''''''''''''''''''''''''

'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-2016

'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 CheckWhiteSpaceInString()

    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

'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

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

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

List of some of my IT blogs:

• Java Exam Notes
• Coding Tips & Techniques
• MySQL Data-types Summary
• HTML Tips & Tricks
• Office Apps Tips & Techniques
• VBA Useful Code Samples
• Useful VBA utilities for Microsoft Word

List of my other blogs:

• Steps to heal tennis elbow
•