Binary Search Algorithm

Apparently, only 10 percent of programmers can correctly code the binary search algorithm. What follows is my attempt to prove once and for all that I belong to that select group of programmers! I implemented the algorithm in Excel VBA.

Option Explicit
'++++++++++++++++++++++++++++++++++++++++++++++++
' Author: Ram Limbu
' Date: 2010/04/28
' Description: Binary Search Algorithm in VBA
'++++++++++++++++++++++++++++++++++++++++++++++++

Sub BinaySearch()
    Dim UpperLimit As Long
    Dim LowerLimit As Long
    Dim Mid As Long
    Dim Val As Long
    Dim NotFound As Boolean
    Dim WS As Worksheet

    On Error GoTo ErrRtn

    'prompt user to enter the number to search
    Val = InputBox("Please, enter the number to search")

    'set WS to the first Worksheet
    Set WS = ThisWorkbook.Worksheets(1)

    NotFound = True
    LowerLimit = 1

    UpperLimit = WS.Cells(65536, 1).End(xlUp).Row

    If UpperLimit = 1 And IsEmpty(WS.Cells(1, 1).Value) Then
        MsgBox "The Column A on Worksheet1 is empty. Exiting ..."
        Exit Sub
    End If

    While NotFound And LowerLimit <= UpperLimit
        Mid = (LowerLimit + UpperLimit) \ 2 ' perform integer division     
        If Val = WS.Cells(Mid, 1) Then
            NotFound = False
        ElseIf Val < WS.Cells(Mid, 1) Then
            UpperLimit = Mid - 1
        Else
            LowerLimit = Mid + 1
        End If
    Wend

    If NotFound Then
        MsgBox Val & " wasn't found"
    Else
        WS.Cells(Mid, 1).Select
        MsgBox Val & " was found at row " & Mid
    End If
    Exit Sub
ErrRtn:
    MsgBox Err.Description
End Sub

The assumptions are as follows: (1) The data set is pre-ordered and (2) located on Column A of the first Worksheet. To keep the code simple, no data validation is performed.

Parsing INI Files With VBA

INI files are still widely used to enable users to configure applications even though their use is deprecated in the Windows world. The recommended method is to write user configuration data to the Windows registry.

From VBA Word, the INI files (and Windows registry) can be accessed and modified through the VBA Object library function System.PrivateProfileString(). In VBA Excel, this library call is not available. To read INI files, one option is to employ the Windows API function GetPrivateProfileString Lib "kernel32". The other option is to write your own INI parser, which is what I did the other day.

Apart from the normal comments (comments start with # in this version of INI), the script also tolerates end-of-line comments.

The script also enforces unique section names by generating an error if a duplicate section name is detected. This is quite important as the script stores the INI data as key-value pairs, and the way it ensures unique key names is by prefixing section names to key names, with a dot separating the two.

The script also gives users the option of loading the generated data file to Teradata using the FastLoad utility.

Sample ini file:

# Author: Ram Limbu
# Date: 2009/11/28
#
#
#

[FILE_SETTINGS] # start of file settings

DestDir=C:\Documents and Settings\Ram_2\My Documents\Excel Projects\Config # don't end this line with slash
Delimiter=,
DestFileName=ErrorFiles.csv

[DATABASE_SETTINGS] # start of database settings

InsertData=Yes # Acceptable values: Yes or No
DbName=IPSHARE
TblName=RL_PP_Hist
DbUsername=cncra/RLIMBU
DbPw=secret

Option Explicit


Const MsgTitle As String = "Wooden Horse Pty Ltd"

Sub Batch_Err_Parser()
    
    '//define constants
    Const OldDelim As String = "|"
    Const NewDefDelim As String = ","
    Const Colon As String = ":"
    Const BackSlash As String = "\"
    
    '//define vars
    Dim LastRow As Long
    Dim Rec As String
    Dim TimeStamp As String
    Dim Msn As String
    Dim RejCode As String
    Dim RejMsg As String
    Dim FileName As String
    Dim DestDir As String
    Dim DestFile As String
    Dim NewDelim As String
    Dim Identifier As String
    Dim OrderNotes As String
    Dim Status As String
    Dim t1 As Double
    Dim t2 As Double
    Dim Rng As Range
    Dim C As Range
    Dim Arr As Variant
    Dim ColonPos1 As Integer
    Dim ColonPos2 As Integer
    Dim TotPasses As Integer
    Dim TotFails As Integer
    Dim RecCtr As Long
    Dim DatExists As Boolean
    Dim fs As Object
    Dim ts As Object
    Dim ws As Worksheet
    Dim INI_COL As New Collection
   
    
    On Error GoTo Err_Rtn:
    
    t1 = Timer
    
    '// call initialization rtn
    InitRtn
    
    '//ensure that it is a batch error rpt
    If Mid(Cells(1, 1), 3, 8) <> "RPT_OPOM" Then
        If Not MsgBox("Is this Marketing Batch Error report?", vbYesNo + vbQuestion, MsgTitle) Then
            Exit Sub
        End If
    End If

    Set ws = ActiveSheet
      
    '// find the last row
    LastRow = ws.Cells(65536, 1).End(xlUp).Row
    
    '// if there is no data, exit
    If LastRow = 1 Then
        MsgBox "Goodbye!", vbExclamation, MsgTitle
        Exit Sub
    End If
    
    '// get ini data
    If Rtn_Config_Col(INI_COL) <> 0 Then  '// 0 = successful func call
        Exit Sub
    End If
    
    '// read new delim from ini settings
    NewDelim = INI_COL.Item("[FILE_SETTINGS].Delimiter")
    If Trim(NewDelim) = "" Then
        NewDelim = NewDefDelim
    End If
    
    '// read identifier
    Identifier = INI_COL.Item("[FILE_SETTINGS].Identifier")
    
    '// if headers are turned on, write them to data file
    If UCase(INI_COL.Item("[FILE_SETTINGS].Headers")) = "ON" Then
        Rec = "service_no" & NewDelim & "status" & NewDelim & "time_stamp" & NewDelim & _
                "rej_code" & NewDelim & "rej_descript" & NewDelim & "identifier" & vbCrLf
    End If
    
    '// create the data range
    Set Rng = ws.Cells(1, 1).Resize(LastRow)
    
    '// loop the cells and parse the records
    Application.DisplayStatusBar = True
    
    For Each C In Rng
        Status = Trim(Left(C, 4))
        If Status = "PASS" Or Status = "FAIL" Then
            RecCtr = RecCtr + 1
            Application.StatusBar = "Processing record: " & RecCtr
            If Status = "PASS" Then
                TotPasses = TotPasses + 1
            Else
                TotFails = TotFails + 1
            End If
            If Status = "FAIL" Or (Status = "PASS" And UCase(INI_COL.Item("[FILE_SETTINGS].FailOnly")) <> "YES") Then
                Arr = Split(C, OldDelim)
                Msn = Right(Arr(4), 10)
                ColonPos1 = InStr(1, Arr(6), Colon, vbTextCompare) ' find 1st position of colon
                ColonPos2 = InStr(ColonPos1 + 1, Arr(6), Colon, vbTextCompare) ' find 2nd position of colon
                RejCode = Trim(Mid(Arr(6), ColonPos1 + 1, ColonPos2 - ColonPos1 - 1)) ' extract rej code
                RejMsg = Trim(Mid(Arr(6), ColonPos2 + 1, Len(Arr(6)))) ' extract rejection description
                OrderNotes = Trim(Arr(7)) 'extract order notes
                OrderNotes = Right(OrderNotes, Len(OrderNotes) - InStr(OrderNotes, Colon)) 'extract only aft colon
                RejMsg = RejMsg & " " & OrderNotes
                RejMsg = Left(RejMsg, 298) ' ensure that rejmsg is not more than 298 characters as db vartext field is 300 only
                Rec = Rec & Msn & NewDelim & Arr(0) & NewDelim & TimeStamp & NewDelim & _
                  RejCode & NewDelim & RejMsg & NewDelim & Identifier & vbCrLf
                DatExists = True
            End If
        ElseIf Status = "DATE" Then
            TimeStamp = Right(C, 19)
        ElseIf UCase(Left(C, 15)) = "INPUT FILE NAME" Then
            FileName = Trim(Right(C, Len(C) - 16))
        End If
        DoEvents
    Next C '// end of main loop
    
    '// if error records exist, write them to a file
    If DatExists Then
        Application.StatusBar = "Writing to text file ..."
        '// read dest folder and file details from ini setting collection
        DestDir = INI_COL.Item("[FILE_SETTINGS].DestDir")
        
        '// if there is no slash at the end of destination folder, put one there
        If Right$(DestDir, 1) <> BackSlash Then
            DestDir = DestDir & BackSlash
        End If
        
        DestFile = INI_COL.Item("[FILE_SETTINGS].DestFile")
        If UCase(Trim(DestFile)) = "DEFAULT" Or Trim(DestFile) = "" Then  '// if no filename has been supplied, name it after error file
            If FileName <> "" Then '// ensure error report filename exists
                DestFile = FileName
            Else
                MsgBox "Error: No valid destination file could be found. Exiting ...", vbOKOnly + vbInformation, MsgTitle
                Exit Sub
            End If
        End If
       
        Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FolderExists(DestDir) Then
            DestFile = DestDir & DestFile  'prepend dest dir
            Set ts = fs.CreateTextFile(DestFile)
            ts.Write Rec
            ts.Close
        Else
            MsgBox DestDir & " doesn't exist or not accessible!", vbOKOnly + vbCritical, MsgTitle
            Exit Sub
        End If
        
        'do clean up
        Set fs = Nothing
        Set ts = Nothing
        Set ws = Nothing
        
        'if the user has elected to write records to db, fastload them
        If UCase(INI_COL.Item("[DATABASE_SETTINGS].InsertData")) = "YES" Then
            '//ensure all other database setting values are provided
            With INI_COL
                If .Item("[DATABASE_SETTINGS].DbName") <> "" And .Item("[DATABASE_SETTINGS].TblName") <> "" & _
                    .Item("[DATABASE_SETTINGS].DbUsername") <> "" And .Item("[DATABASE_SETTINGS].DbPw") <> "" Then
                    DbRtn Db:=.Item("[DATABASE_SETTINGS].DbName"), Tbl:=.Item("[DATABASE_SETTINGS].TblName"), _
                        UsrNm:=.Item("[DATABASE_SETTINGS].DbUsername"), Pw:=.Item("[DATABASE_SETTINGS].DbPw"), _
                        InputFile:=DestFile, TargetDir:=DestDir, Start:=IIf(UCase(.Item("[FILE_SETTINGS].Headers")) = "ON", 2, 1), _
                            Delim:=NewDelim
                Else
                    MsgBox "Since you didn't provide all required database settings, records were not " & vbCrLf _
                        & "written to database!", vbInformation + vbOKOnly, MsgTitle
                End If
            End With
            
        End If
        
        t2 = Timer
        Application.StatusBar = "Done!"
        MsgBox "Finito! Time taken = " & Format(t2 - t1, "##0.000") & " seconds" & vbCrLf _
            & "Total Passes = " & TotPasses & vbCrLf _
            & "Total Fails = " & TotFails & vbCrLf _
            & "Total Records = " & TotPasses + TotFails, vbInformation + vbOKOnly, MsgTitle
        
    End If
    Application.StatusBar = ""
    Exit Sub
Err_Rtn:
    Application.StatusBar = ""
    MsgBox Err.Description, vbInformation + vbOKOnly, MsgTitle
End Sub

Private Function Rtn_Config_Col(ByRef INI_COL As Collection) As Integer
    Dim INI_File As String
    Dim Rec As String
    Dim SecName As String
    Dim Kee As String
    Dim val As String
    Dim SubStrPos As Integer
    Dim fs As Object
    Dim f As Object
    Dim flds As Object
    Dim SecCol As New Collection

    
    '// define some constants to make script more userfrieldly
    Const READ_ONLY As Integer = 1
    Const CommStr As String = "#"
    Const Eq As String = "="
    Const SecStart As String = "["
    Const SecEnd As String = "]"
    Const MinValLen As String = 3
    Const Blank As String = ""
    
    Set fs = CreateObject("WScript.Shell")
    Set flds = fs.SpecialFolders
    INI_File = flds("mydocuments") & "\Batch_Errors\Batch_Errors.ini"
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    '//ensure ini file exists
    If Not fs.FileExists(INI_File) Then
        MsgBox "My Documements\Batch_Errors folder " & vbCrLf & _
        "or INI file does not exist! Exiting ...", vbCritical + vbOKOnly, MsgTitle
        Rtn_Config_Col = -1
    End If
    
    Set f = fs.OpenTextFile(INI_File, READ_ONLY)
    
    '//read the ini file
    
    Do Until f.AtEndOfStream
    
        Rec = Trim(f.ReadLine)
        
        '// ignore comments and blank lines
        If Left(Rec, 1) <> CommStr And Rec <> Blank Then
            '// check to see if there are comments at end of key-value pair
            '// if so, take them out of current record
            SubStrPos = InStr(2, Rec, CommStr)
            
            If SubStrPos > 0 Then '// end of line comments exists
                Rec = Trim(Left(Rec, SubStrPos - 1)) '// eliminate comments
            End If
                
            '//check for section name
            If Left(Rec, 1) = SecStart Then
                If Right(Rec, 1) = SecEnd And Len(Rec) >= MinValLen Then '// ensure it is valid section name
                    'ensure that there are no duplicate section names
                    SecName = Rec
                    On Error Resume Next
                    SecCol.Add SecName, SecName
                    If Err <> 0 Then
                        MsgBox "Error: The INI file has duplicate section names! Exiting ...", vbCritical + vbOKOnly, MsgTitle
                        Rtn_Config_Col = -1
                    End If
                End If
            Else
                '// check if it is key-value pair
                SubStrPos = InStr(2, Rec, Eq)
                If SubStrPos > 0 And Len(Rec) >= MinValLen Then
                    '// insert key-value pair into collection
                    '// prepend section name to key name to make it unique
                    Kee = Left(Rec, SubStrPos - 1)
                    val = Trim(CleanData(Right(Rec, Len(Rec) - SubStrPos)))
                    Kee = Trim(CleanData(SecName & "." & Kee))
                    INI_COL.Add val, CStr(Kee)
                End If
            End If
        End If
    Loop
    f.Close
    Set fs = Nothing
    Set flds = Nothing
    Rtn_Config_Col = 0
End Function

Private Function CleanData(Data As String) As String
    Dim i As Integer
    For i = 0 To 31
        While InStr(1, Data, Chr(i)) > 0
            Data = Replace(Data, Chr(i), " ")
        Wend
    Next i
    
    For i = 127 To 255
        While InStr(1, Data, Chr(i)) > 0
            Data = Replace(Data, Chr(i), " ")
        Wend
    Next i
    CleanData = Data
End Function

Private Sub InitRtn()
    '// in this routine, ensure that user has
    '// Batch_Errors.ini file within Batch_Errors in My Documents folder. If not, create one
    '// and inform user
    Dim fso As Object
    Dim fws As Object
    Dim sfld As Object
    Dim Rec As String
    Dim txt_file_o As Object
       
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fws = CreateObject("WScript.Shell")
    Set sfld = fws.SpecialFolders
    If Not fso.FolderExists(sfld("mydocuments") & "\Batch_Errors") Then
        '// create Batch_Errors folder
        Application.StatusBar = "Creating " & sfld("mydocuments") & "\Batch_Errors"
        fso.CreateFolder (sfld("mydocuments") & "\Batch_Errors")
        Application.StatusBar = "Creating .ini file ..."
        
        '// create ini file
        Rec = "# This .ini file was created by batch error parser on " & Format(Now, "YYYY-MM-DD HH:MM:SS") & vbCrLf & "#" & vbCrLf
        Rec = Rec & "# Comments start with the hash symbol (#), just like this line" & vbCrLf & "#" & vbCrLf & "#" & vbCrLf
        Rec = Rec & "# start of file settings" & vbCrLf & vbCrLf
        Rec = Rec & "[FILE_SETTINGS]" & vbCrLf & vbCrLf
        Rec = Rec & "DestDir=" & sfld("mydocuments") & "\Batch_Errors" & vbCrLf
        Rec = Rec & "Delimiter=,             # leaving it blank will choose comma as default delimiter" & vbCrLf
        Rec = Rec & "DestFile=default        # the destination file name defaults to error report name" & vbCrLf
        Rec = Rec & "Headers=On              # On or Off" & vbCrLf
        Rec = Rec & "Identifier=             # write something descriptive to identify service numbers or leave blank" & vbCrLf
        Rec = Rec & "FailOnly=No             # Yes or No. If Yes, only services that returned rejections will be extracted" & vbCrLf & vbCrLf
        Rec = Rec & "# start of database settings" & vbCrLf & vbCrLf
        Rec = Rec & "# If you want the error report data to insert into a table, then provide appropriate values " & vbCrLf
        Rec = Rec & "# for the following database settings, starting with 'InsertData'." & vbCrLf
        Rec = Rec & "# *** Please, note: you need to create the required table as follows" & vbCrLf
        Rec = Rec & "# before attempting to load data into it via this utility!" & vbCrLf
        Rec = Rec & "#" & String(50, "-") & vbCrLf
        Rec = Rec & "# CREATE SET TABLE DB_FOO.TBL_BAR (" & vbCrLf
        Rec = Rec & "#      service_no VARCHAR(20)" & vbCrLf
        Rec = Rec & "#     ,status VARCHAR(10)" & vbCrLf
        Rec = Rec & "#     ,tm_stamp VARCHAR(30)" & vbCrLf
        Rec = Rec & "#     ,rej_code VARCHAR(10)" & vbCrLf
        Rec = Rec & "#     ,rej_descript VARCHAR(300)" & vbCrLf
        Rec = Rec & "#     ,identifier VARCHAR(50)" & vbCrLf
        Rec = Rec & "#     ,open_dt DATE" & vbCrLf
        Rec = Rec & "#     ,close_dt VARCHAR(30)" & vbCrLf
        Rec = Rec & "# ) PRIMARY INDEX (service_no);" & vbCrLf
        Rec = Rec & "#" & String(50, "-") & vbCrLf & vbCrLf
        Rec = Rec & "# Since the data get FastLoaded, you need to have FastLoad utility installed on your machine." & vbCrLf & vbCrLf
        Rec = Rec & "[DATABASE_SETTINGS]" & vbCrLf & vbCrLf
        Rec = Rec & "InsertData=No          # Yes or No. To insert data into database, write 'Yes'" & vbCrLf
        Rec = Rec & "DbName=xx_my_db         # replace 'xx_my_db' with your database name, i.e. IPSHARE" & vbCrLf
        Rec = Rec & "TblName=xx_my_tbl       # replace 'xx_my_tbl' with your table name" & vbCrLf
        Rec = Rec & "DbUsername=cncra/jdoe   # replace 'cncra/jdoe' with your data source name/username" & vbCrLf
        Rec = Rec & "DbPw=secret             # replace 'secret' with your password"
        
        Set txt_file_o = fso.CreateTextFile(sfld("mydocuments") & "\Batch_Errors\Batch_Errors.ini")
        txt_file_o.Write Rec
        txt_file_o.Close
        Set txt_file_o = Nothing
        Application.StatusBar = ""
    End If
    
End Sub

Sub DbRtn(Db As String, Tbl As String, UsrNm As String, Pw As String, InputFile As String, TargetDir As String, Start As Integer, Delim As String)
    '// this routine fastloads error records into named tables
    
    Dim flScript As String
    Dim fso As Object
    Dim fo As Object
    Dim ScriptInput As String
    Dim ScriptOutput As String
    Dim ShStatus As Double
    Dim BatOut As String
    
    
    '// start creating fastload script
    
    flScript = "/* " & String(84, "+") & " */" & vbCrLf
    flScript = flScript & "/* FASTLOAD SCRIPT CREATED BY BATCH ERROR PARSER  */" & vbCrLf
    flScript = flScript & "/* ON " & Format(Now, "YYYY-MM-DD hh:mm:ss") & " TO FASTLOAD BATCH ERROR DATA  */" & vbCrLf
    flScript = flScript & "/* " & String(84, "+") & " */" & vbCrLf
    flScript = flScript & vbCrLf & "/* Setup FastLoad parameters  */" & vbCrLf & vbCrLf
    flScript = flScript & "SESSIONS 50;" & vbCrLf
    flScript = flScript & "ERRLIMIT 50;" & vbCrLf
    flScript = flScript & "LOGON " & UsrNm & ", " & Pw & ";" & vbCrLf
    flScript = flScript & "SHOW VERSIONS;" & vbCrLf
    flScript = flScript & "RECORD " & Start & ";" & vbCrLf
    flScript = flScript & "SET RECORD VARTEXT """ & Delim & """ DISPLAY_ERRORS NOSTOP;" & vbCrLf & vbCrLf
    flScript = flScript & "/* Define text file layout and input file */" & vbCrLf & vbCrLf
    flScript = flScript & "DEFINE service_number (VARCHAR(20))" & vbCrLf
    flScript = flScript & "     ,status (VARCHAR(10))" & vbCrLf
    flScript = flScript & "     ,tm_stamp (VARCHAR(30))" & vbCrLf
    flScript = flScript & "     ,rej_code (VARCHAR(10))" & vbCrLf
    flScript = flScript & "     ,rej_descript (VARCHAR(300))" & vbCrLf
    flScript = flScript & "     ,identifier (VARCHAR(50)) " & vbCrLf
    flScript = flScript & "FILE=" & InputFile & ";" & vbCrLf & vbCrLf
    flScript = flScript & "SHOW;" & vbCrLf & vbCrLf
    flScript = flScript & "BEGIN LOADING " & Db & "." & Tbl & vbCrLf
    flScript = flScript & " ERRORFILES " & Db & ".Batch_Err1, " & Db & ".Batch_Err2" & vbCrLf
    flScript = flScript & " CHECKPOINT 500;" & vbCrLf & vbCrLf
    flScript = flScript & "INSERT INTO " & Db & "." & Tbl & " VALUES" & vbCrLf
    flScript = flScript & "  ( :service_number " & vbCrLf
    flScript = flScript & "    ,:status " & vbCrLf
    flScript = flScript & "    ,:tm_stamp " & vbCrLf
    flScript = flScript & "    ,:rej_code " & vbCrLf
    flScript = flScript & "    ,:rej_descript " & vbCrLf
    flScript = flScript & "    ,:identifier " & vbCrLf
    flScript = flScript & "    ,CURRENT_DATE " & vbCrLf
    flScript = flScript & "    ,'2899-12-31'); " & vbCrLf & vbCrLf
    flScript = flScript & "END LOADING;" & vbCrLf
    flScript = flScript & "LOGOFF;"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    ScriptInput = TargetDir & "FastLoadThis" & ".src"
    ScriptOutput = TargetDir & "FastLoad_" & Format(Date, "YYYY_MM_DD") & ".log"
    BatOut = TargetDir & "Batch_Errors.bat"
    
    On Error Resume Next
        Kill BatOut
        Kill ScriptInput
    On Error GoTo 0
    
    Set fo = fso.CreateTextFile(ScriptInput)
    fo.Write flScript
    fo.Close
    
    '//create bat file
    flScript = "FastLoad < """ & ScriptInput & """ > """ & ScriptOutput & """ 2>&1"
    Set fo = fso.CreateTextFile(BatOut)
    fo.Write flScript
    fo.Close
    
    'do clean-up
    Set fso = Nothing
    Set fo = Nothing
    
    '//start fastload
    Call Shell(BatOut)

End Sub

Deleting Rows in Excel with VBA

Deleting and shifting Rows up in VBA is a straightforward task that nevertheless hides a few traps. Say, any Row that has a numeric value in Column 'A' needs to be deleted and the Rows below shifted up. A VBA solution such as the one that follows does not work.

Option Explicit 

Sub DeleteRows()
    Dim LastRow, Ctr As Long  

    '// find the last Row with data
    LastRow = Cells(65536, 1).End(xlUp).Row

    '// loop through the Rows, deleteing Rows that have a
    '// numberic value in Column 'A' and shifting Rows up   

    For Ctr = 1 To LastRow
        If IsNumeric(Cells(Ctr, 1)) Then
            Cells(Ctr, 1).EntireRow.Delete Shift:=xlShiftUp
        End If
    Next Ctr
End Sub 

The problem is that if two or more consecutive Rows have numeric values in Column 'A', not all the Rows that need to be deleted get deleted. Why? Say that Rows 3 and 4 have numeric values in Column 'A'. When Row 3 is deleted, Row 4 moves up to take its place, in effect becoming Row 3. Meanwhile, the loop counter gets incremented in the next pass from 3 to 4, with the code scanning the value in Cell A4 but inadvertently skipping the value in Cell A3. 

An elegant solution to this problem is to start looping at the last Row with data in the Worksheet and move up one Row at a time, deleting and shifting Rows up when the required condition is satisfied. Here is the solution: 

Option Explicit 

Sub DeleteRows()
    Dim LastRow, Ctr As Long   

    '// find the last row with data
    LastRow = Cells(65536, 1).End(xlUp).Row   

    '// loop through the Rows, deleteing Rows that have a
    '// numberic value in Column 'A' and shifting Rows up    

    For Ctr = LastRow To 1 Step -1
        If IsNumeric(Cells(Ctr, 1)) Then
            Cells(Ctr, 1).EntireRow.Delete Shift:=xlShiftUp
        End If
    Next Ctr 
End Sub

An Excel & Outlook Hack

Last week, one of my workmates asked me if I could construct an Excel solution to automate a particularly tedious task he had to perform on a daily basis. The task involved opening emails, copying the senders, editing them, and searching for them in Workbooks. If the searches failed, the emails would be flagged as unread and the procedure repeated, ad nauseum. The idea was to ensure that all the senders were found in the Workbooks.

As an Excel VBA hacker, the only part that was not immediately apparent to me was the method to access the non-default Outlook mailbox in which my workmate was receiving the emails, which totaled around 2/3 hundreds a day. After a few google searches, I found the workaround and managed to construct an Excel add-in that now helps my workmate perform the task with a few clicks.

The first step was to add the Outlook object code library from the Excel VBA IDE by clicking Tools > References, and then ticking Microsoft Outlook 11.0 Object Library and clicking Ok on the dialogue box. Next, the following procedure was created.

Option Explicit

Sub mainProc()

    Application.ScreenUpdating = False

    '//////////////////////////////////////////////
    ' declare the vars
    '//////////////////////////////////////////////

    Dim Sh As Worksheet
    Dim Olapp As Object
    Dim Olns As Namespace
    Dim Fldr As MAPIFolder
    Dim OlMail As Variant
    Dim intFinalRow As Integer
    Dim i, j, k As Integer
    Dim intProgCent As Integer
    Dim intTotMails As Integer
    Dim strFolderId As String

    On Error GoTo Err_Rtn:

    strFolderId = "xxx"

    Set Sh = ActiveSheet
    Set Olapp = New Outlook.Application
    Set Olns = Olapp.GetNamespace("MAPI")
    Set Fldr = Olns.GetFolderFromID(strFolderId)
    intTotMails = Fldr.Items.Count
    j = 0
    k = 0
    frmProgressBar.Show

    intFinalRow = Sh.Range("F65536").End(xlUp).Row

    For Each OlMail In Fldr.Items
        j = j + 1
        intProgCent = (j / intTotMails) * 100
        With frmProgressBar
            .ProgressBar1.Value = intProgCent
            .lblPercent = Str(intProgCent) & "%"
        End With

    If OlMail.UnRead = True Then
        For i = 1 To intFinalRow
            With Sh
                If Trim(.Range("F" & i).Value) = _
                                Right(Trim(OlMail.SenderName), 9) Then
                    .Range("A" & i & ":K" & i).Interior.ColorIndex = 17
                    OlMail.UnRead = False
                    k = k + 1
                    Exit For
                End If
            End With
        Next i
    End If
    DoEvents
    Next OlMail
    Unload frmProgressBar
    MsgBox "Total found " & k
    Set Fldr = Nothing
    Set Olns = Nothing
    Set Olapp = Nothing
    Set Sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
Err_Rtn:
    Unload frmProgressBar
    Application.ScreenUpdating = True
    MsgBox Err.Description
End Sub

The code is self-explanatory. It loops through all the emails in the folder with id equal to the value of strFolderId. If an email is not already read, the nine rightmost characters of the sender name are extracted with the inbuilt VBA function Right() and compared with the values in the 'F' column of the active worksheet. If a match is found, the color of the row of the matched value is changed and the email flagged as read. If no match is found, the code interrogates the next email.

There is also a progress bar and a pop-up dialogue box that displays the total number of matches found at the end of the program execution.

Only one thing needs a bit more explanation. The variable strFolderId is set to "xxx" in line 24. In fact, the value is a long string that is found by running the following macro in Outlook.

Option Explicit

Sub findFolderId()
    Dim Ons As Outlook.NameSpace
    Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    Set Ons = Application.GetNamespace("MAPI")
    Set Fldr = Ons.PickFolder
    Debug.Print Fldr.StoreID
    Set Ons = Nothing
    Fldr = Nothing
    On Error GoTo 0
End Sub

The folder id will be displayed in the Immediate window.

One final note. Since this code implements 'early binding' after manually adding the reference to the Outlook object code library, the application will fail to work if/when the object library is upgraded, as might happen when a newer version of MS Office suite is installed. To preempt this issue, the code should be changed to use 'late binding'. In some future post, that is what I might do.