'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------------
