Extracting from Outlook Email to Excel Using Multiple RegEx Patterns

Hi experts,

I've worked on this for a couple of days and I am stuck. Here's the scenario:

    I have some incoming emails with data that I want to parse and insert into Excel.
      I am using regular expressions to do this.
        Some of the pattern matches require a replacement to transform the data (It is coordinate data and the format in the email needs to be converted.
          The coordinates are listed two different ways in the emails. This requires two different replacements because the replacement is different depending on which pattern matches the string.

          I have all this figured out and the code below works, except for one thing. I need to use a total of 10 patterns. If there isn't a match, the "i" counter still ticks up one, so when it matches the next pattern, it shifts the data over one column to the right. So data from Sample A works fine, but when it parses data from Sample B, it shifts the data into the wrong columns.

          Part of me thinks this has to do with arrColumns being tied to (i), but I tried inserting another loop and I couldn't get that to work. I also tried adding i = i - 1 when the pattern didn't match (to keep the "i" counter from adding one and thus moving to the next column), but that created an endless loop. So I am stuck.

          So in a nutshell I need to be able to test multiple patterns and insert the matches (or transformed matches) into Excel.

          I've attached the two types of sample data, the "good" output in Excel, and the "bad" output in Excel (what happens when I use the two additional patterns). The code is also commented so hopefully you can help me figure it out.

          Disclaimer: I am pushing the extent of my knowledge in this area...I just cobbled together some code from various sources to get where I am.

          So the code below works, except for the problem described above...

          Sub ExtractDataToExcel(oItem As MailItem)
              Const xlUp = -4162
              Dim objExcel As Object
              Dim objMaster As Object
              Dim objSheet As Object
              Dim objRegExp As RegExp
              Dim i As Integer
              Dim enviro As String
              Dim bXStarted As Boolean
              Dim objMatch
              
          
              enviro = CStr(Environ("USERPROFILE"))
              Const strWSName As String = "data-export"
              strWBName = enviro & "\Desktop\pings.xlsx"
              
              'Use FileExists function to determine the availability of the workbook
              If Not FileExists(strWBName) Then Exit Sub
              
              On Error Resume Next
              ' Open Excel, hide it
              Set objExcel = GetObject(, "Excel.Application")
              If Err <> 0 Then
                  Application.StatusBar = "Please wait while Excel source is opened ... "
                  Set objExcel = CreateObject("Excel.Application")
                  objExcel.Visible = False
                  bXStarted = True
              End If
              
          
              ' Define patterns to extract from email
              Dim arrPatterns As Variant
              
              ' If I use all the patterns below (10 patterns total) , it shifts the data right into the wrong columns
              ' because if there isn't a match on the pattern, the "i" counter still ticks up one (which adds 1 to the column)
              'arrPatterns = Array("\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT", "\d{7}", "X{10}[A-WYZ0-9]+", "X{6}\d{4}", "(Confidence\sLevel(\s)+)(\d{2,3})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N", "N(\d{2})\.(\d{5,})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W", "W(\d{2})\.(\d{5,})", "\d{1,4}\smeter(s)?\b", "\b\d\w-\w{4}\b")
              
              ' If I use the patterns below (8 patterns total), it works for data like in Sample A, but not Sample B
              ' (because the Lat/Long format is different in Sample B so that needs to be captured by the additional 2 patterns listed in the arrPatterns above)
              arrPatterns = Array("\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT", "\d{7}", "X{10}[A-WYZ0-9]+", "X{6}\d{4}", "(Confidence\sLevel(\s)+)(\d{2,3})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W", "\d{1,4}\smeter(s)?\b", "\b\d\w-\w{4}\b")
              
             
              Dim arrColumns As Variant
              arrColumns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
          
              ' Load the workbook
              Set objMaster = objExcel.Workbooks.Open(strWBName)
              
              
              ' If the sheet doesn't exist in the workbook, add it.
              ' Uses CreateSheetIf helper function
              CreateSheetIf (strWSName)
              
              Set objSheet = objMaster.Sheets(strWSName)
          
              ' Calculate next row to add after existing used rows
              intRow = objSheet.Range("A" & objSheet.Rows.Count).End(-4162).Row + 1
          
              ' Create RegEx object for searching
              Set objRegExp = New RegExp
          
              ' Search email body for each pattern
              For i = 0 To UBound(arrPatterns)
                  objRegExp.Pattern = arrPatterns(i)
                  objRegExp.Global = False
                  Set colMatches = objRegExp.Execute(oItem.Body)
                  
                  If colMatches.Count > 0 Then ' If there is a match, continue...
                      
                      Set objMatch = colMatches.Item(0)
                      strMatch = objMatch.Value
                 
                      ' some of the pattern matches require transformation
                      ' if the match is one of the patterns below, apply the listed replacement
                      Select Case objRegExp.Pattern
                      
                      Case "(Confidence\sLevel(\s)+)(\d{2,3})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$3", False)
          
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2$3$4", False)
          
                      Case "N(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2", False)
                      
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2$3$4", False)
                      
                      Case "W(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2", False)
                                  
                      Case Else
                       strReplace = strMatch ' If none of the above replacement patterns match, just insert the original match into Excel
                       
                      End Select
             
                  objSheet.Cells(intRow, arrColumns(i)).Value = strReplace ' Do the insert
                  
                  Else
                  ' I feel like my solution should go here but so far no luck
                  ' I tried i = i - 1 here, thinking if there was no match on the pattern, then don't advance the "i" counter
                  ' but that resulted in an endless loop
                  End If
              Next
              
              ' this just adds a calculated value in the rightmost column
              objSheet.Cells(intRow, arrColumns(i)).Value = "=HYPERLINK(""https://www.google.com/webhp?ie=UTF-8#q=""&F2&"",""&G2,""Map these coordinates"")"
               
              ' Save updated Excel file
              objMaster.Save
              objMaster.Close SaveChanges:=True
              If bXStarted Then
                  objExcel.Quit
              End If
              
              ' Release objects
              Set objRegExp = Nothing
              Set objSheet = Nothing
              Set objMaster = Nothing
              Set objExcel = Nothing
                
          End Sub
          
          Sub ExtractEmailData()
          ' Call this macro from a button in Outlook
          Dim oItem As MailItem
          If Application.ActiveExplorer.Selection.Count = 0 Then
          MsgBox "Please select one or more emails first!", vbCritical, "Error"
          Exit Sub
          End If
          For Each oItem In ActiveExplorer.Selection
          ExtractDataToExcel oItem
          Next oItem
          Set oItem = Nothing
          MsgBox "The selected emails have been extracted.", , "Initech"
          End Sub
          
          Public Function FileExists(ByVal Filename As String) As Boolean
          Dim nAttr As Long
          On Error GoTo NoFile
          nAttr = GetAttr(Filename)
          If (nAttr And vbDirectory) <> vbDirectory Then
          FileExists = True
          End If
          NoFile:
          End Function
          
          Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
              Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = False, _
              Optional MultiLine As Boolean = False)
              
              ' Function written by Patrick G. Matthews.
          	' Original source:
          	' http://stackoverflow.com/questions/10393087/expressing-basic-access-query-criteria-as-regular-expressions
          
              
              Static RegX As Object
              
              If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
              With RegX
                  .Pattern = PatternStr
                  .Global = ReplaceAll
                  .IgnoreCase = Not MatchCase
                  .MultiLine = MultiLine
              End With
              
              RegExpReplace = RegX.Replace(LookIn, ReplaceWith)
              
          End Function
          
          Function CreateSheetIf(strSheetName As String) As Boolean
              Dim wsTest As Worksheet
              CreateSheetIf = False
               
              Set wsTest = Nothing
              On Error Resume Next
              Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
              On Error GoTo 0
               
              If wsTest Is Nothing Then
                  CreateSheetIf = True
                  Worksheets.Add.Name = strSheetName
              End If
               
          End Function
          

          Open in new window

          sample_data.jpg
          sample_excel_right.jpg
          sample_excel_wrong.jpg
          LVL 2
          Jim MAsked:
          Who is Participating?

          [Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

          x
          I wear a lot of hats...

          "The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

          Rgonzo1971Commented:
          Hi,

          pls try
          Sub ExtractDataToExcel(oItem As MailItem)
              Const xlUp = -4162
              Dim objExcel As Object
              Dim objMaster As Object
              Dim objSheet As Object
              Dim objRegExp As RegExp
              Dim i As Integer
              Dim enviro As String
              Dim bXStarted As Boolean
              Dim objMatch
              
          
              enviro = CStr(Environ("USERPROFILE"))
              Const strWSName As String = "data-export"
              strWBName = enviro & "\Desktop\pings.xlsx"
              
              'Use FileExists function to determine the availability of the workbook
              If Not FileExists(strWBName) Then Exit Sub
              
              On Error Resume Next
              ' Open Excel, hide it
              Set objExcel = GetObject(, "Excel.Application")
              If Err <> 0 Then
                  Application.StatusBar = "Please wait while Excel source is opened ... "
                  Set objExcel = CreateObject("Excel.Application")
                  objExcel.Visible = False
                  bXStarted = True
              End If
              
          
              ' Define patterns to extract from email
              Dim arrPatterns As Variant
              
              ' If I use all the patterns below (10 patterns total) , it shifts the data right into the wrong columns
              ' because if there isn't a match on the pattern, the "i" counter still ticks up one (which adds 1 to the column)
              'arrPatterns = Array("\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT", "\d{7}", "X{10}[A-WYZ0-9]+", "X{6}\d{4}", "(Confidence\sLevel(\s)+)(\d{2,3})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N", "N(\d{2})\.(\d{5,})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W", "W(\d{2})\.(\d{5,})", "\d{1,4}\smeter(s)?\b", "\b\d\w-\w{4}\b")
              
              ' If I use the patterns below (8 patterns total), it works for data like in Sample A, but not Sample B
              ' (because the Lat/Long format is different in Sample B so that needs to be captured by the additional 2 patterns listed in the arrPatterns above)
              arrPatterns = Array("\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT", "\d{7}", "X{10}[A-WYZ0-9]+", "X{6}\d{4}", "(Confidence\sLevel(\s)+)(\d{2,3})", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N", "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W", "\d{1,4}\smeter(s)?\b", "\b\d\w-\w{4}\b")
              
             
              Dim arrColumns As Variant
              arrColumns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
          
              ' Load the workbook
              Set objMaster = objExcel.Workbooks.Open(strWBName)
              
              
              ' If the sheet doesn't exist in the workbook, add it.
              ' Uses CreateSheetIf helper function
              CreateSheetIf (strWSName)
              
              Set objSheet = objMaster.Sheets(strWSName)
          
              ' Calculate next row to add after existing used rows
              intRow = objSheet.range("A" & objSheet.Rows.Count).End(-4162).Row + 1
          
              ' Create RegEx object for searching
              Set objRegExp = New RegExp
          
              ' Search email body for each pattern
              For i = 0 To UBound(arrPatterns)
                  objRegExp.Pattern = arrPatterns(i)
                  objRegExp.Global = False
                  Set colMatches = objRegExp.Execute(oItem.Body)
                  
                  If colMatches.Count > 0 Then ' If there is a match, continue...
                      
                      Set objMatch = colMatches.item(0)
                      strMatch = objMatch.Value
                 
                      ' some of the pattern matches require transformation
                      ' if the match is one of the patterns below, apply the listed replacement
                      Select Case objRegExp.Pattern
                      
                      Case "(Confidence\sLevel(\s)+)(\d{2,3})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$3", False)
          
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2$3$4", False)
          
                      Case "N(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2", False)
                      
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2$3$4", False)
                      
                      Case "W(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2", False)
                                  
                      Case Else
                      strReplace = strMatch ' If none of the above replacement patterns match, just insert the original match into Excel
                       
                      End Select
                  
                  Else
                      strReplace = ""
                  End If
                  objSheet.Cells(intRow, arrColumns(i)).Value = strReplace ' Do the insert
              Next
              
              ' this just adds a calculated value in the rightmost column
              objSheet.Cells(intRow, arrColumns(i)).Value = "=HYPERLINK(""https://www.google.com/webhp?ie=UTF-8#q=""&F2&"",""&G2,""Map these coordinates"")"
               
              ' Save updated Excel file
              objMaster.Save
              objMaster.Close SaveChanges:=True
              If bXStarted Then
                  objExcel.Quit
              End If
              
              ' Release objects
              Set objRegExp = Nothing
              Set objSheet = Nothing
              Set objMaster = Nothing
              Set objExcel = Nothing
                
          End Sub
          
          Sub ExtractEmailData()
          ' Call this macro from a button in Outlook
          Dim oItem As MailItem
          If Application.ActiveExplorer.Selection.Count = 0 Then
          MsgBox "Please select one or more emails first!", vbCritical, "Error"
          Exit Sub
          End If
          For Each oItem In ActiveExplorer.Selection
          ExtractDataToExcel oItem
          Next oItem
          Set oItem = Nothing
          MsgBox "The selected emails have been extracted.", , "Initech"
          End Sub
          
          Public Function FileExists(ByVal Filename As String) As Boolean
          Dim nAttr As Long
          On Error GoTo NoFile
          nAttr = GetAttr(Filename)
          If (nAttr And vbDirectory) <> vbDirectory Then
          FileExists = True
          End If
          NoFile:
          End Function
          
          Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
              Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = False, _
              Optional MultiLine As Boolean = False)
              
              ' Function written by Patrick G. Matthews.
              ' Original source:
              ' http://stackoverflow.com/questions/10393087/expressing-basic-access-query-criteria-as-regular-expressions
          
              
              Static RegX As Object
              
              If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
              With RegX
                  .Pattern = PatternStr
                  .Global = ReplaceAll
                  .IgnoreCase = Not MatchCase
                  .MultiLine = MultiLine
              End With
              
              RegExpReplace = RegX.replace(LookIn, ReplaceWith)
              
          End Function
          
          Function CreateSheetIf(strSheetName As String) As Boolean
              Dim wsTest As Worksheet
              CreateSheetIf = False
               
              Set wsTest = Nothing
              On Error Resume Next
              Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
              On Error GoTo 0
               
              If wsTest Is Nothing Then
                  CreateSheetIf = True
                  Worksheets.Add.Name = strSheetName
              End If
               
          End Function
          

          Open in new window

          regards
          0
          Jim MAuthor Commented:
          Hi, thanks for the response. I get the same result as before, though  (same as the sample_excel_wrong attachment).

           One thing I forgot to do is uncomment line 36 above and comment out line 40, because line 36 is the line with the extra two patterns I need to match.

          It seems like the root problem is when there is no match, the counter is still progressing, so the next time there is a match, it's inserted into the wrong column. I did try creating a separate counter "j" for the column array (to use in line 100 above), because as it is, it's tied to the pattern array "i"), but I couldn't get that approach to work, either.
          0
          Jim MAuthor Commented:
          Wait, let me test a little more...
          0
          Big Business Goals? Which KPIs Will Help You

          The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

          Jim MAuthor Commented:
          Yeah, same result as I had before, sorry.
          0
          Rgonzo1971Commented:
          it would be easier to give the colun where the pattern is

                      Select Case objRegExp.Pattern
                      
                      Case "(Confidence\sLevel(\s)+)(\d{2,3})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$3", False)
                      strCol = "A"
          
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2$3$4", False)
                      strCol = "B"
          ' then
                      objSheet.Cells(intRow, strCol).Value = strReplace
          

          Open in new window

          0

          Experts Exchange Solution brought to you by

          Your issues matter to us.

          Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

          Start your 7-day free trial
          Jim MAuthor Commented:
          Ok, I was able to get it working using your approach above to hard-code the columns. I was hoping to solve this in a more flexible way so that I could avoid hard-coding anything, but it did fix the problem and I got the project done so I guess there's something to be said for picking your battles hahaha.

          Thanks very much for your time and assistance. The completed and working sub is below for future reference for others.

          Sub ExtractDataToExcel(oItem As MailItem)
              Const xlUp = -4162
              Dim objExcel As Object
              Dim objMaster As Object
              Dim objSheet As Object
              Dim objRegExp As RegExp
              Dim i As Integer
              Dim enviro As String
              Dim bXStarted As Boolean
              Dim objMatch
              
          
              enviro = CStr(Environ("USERPROFILE"))
              Const strWSName As String = "ping-data-export"
              'strWBName = enviro & "\Desktop\att-ping-data.xlsx"
              strWBName = "C:\att-ping-data.xlsx"
              
              'Use FileExists function to determine the availability of the workbook
              If Not FileExists(strWBName) Then Exit Sub
              
              On Error Resume Next
              ' Open Excel, hide it
              Set objExcel = GetObject(, "Excel.Application")
              If Err <> 0 Then
                  Application.StatusBar = "Please wait while Excel source is opened ... "
                  Set objExcel = CreateObject("Excel.Application")
                  objExcel.Visible = False
                  bXStarted = True
              End If
              
          
              ' Define patterns to extract from email
              Dim arrPatterns As Variant
              
              ' to add another search pattern:
              '1) add to the array below
              '2) add it in the case statement below
              
              arrPatterns = Array("\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT", _
              "\d{7}", _
              "X{10}[A-WYZ0-9]+", "X{6}\d{4}", _
              "(Confidence\sLevel(\s)+)(\d{2,3})", _
              "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N", _
              "N(\d{2})\.(\d{5,})", _
              "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W", _
              "W(\d{2})\.(\d{5,})", _
              "\d{1,4}\smeter(s)?\b", _
              "\b\d\w-\w{4}\b", _
              "(Sent:\s)(.*(A|P)M)", _
              "(Initiated\s)(\d{4}/\d{2}/\d{2}\s\d{2}:\d{2}:\d{2}\s.*)", _
              "\bUnable\sto\sobtain\sposition\sinformation\b")
              
              ' Load the workbook
              Set objMaster = objExcel.Workbooks.Open(strWBName)
              
              
              ' If the sheet doesn't exist in the workbook, add it.
              ' Uses CreateSheetIf helper function
              CreateSheetIf (strWSName)
              
              Set objSheet = objMaster.Sheets(strWSName)
              
              ' Set Column Names
              Cells(1, "A") = "Located On"
              Cells(1, "B") = "IRB"
              Cells(1, "C") = "Record ID"
              Cells(1, "D") = "Locator"
              Cells(1, "E") = "Confidence Level"
              Cells(1, "F") = "Latitude"
              Cells(1, "G") = "Longitude"
              Cells(1, "H") = "Radius"
              Cells(1, "I") = "Reference"
              Cells(1, "J") = "Email Sent"
              Cells(1, "K") = "Initiated On"
              Cells(1, "L") = "Google Map Link"
          
              ' Calculate next row to add after existing used rows
              intRow = objSheet.Range("A" & objSheet.Rows.Count).End(-4162).Row + 1
          
              ' Create RegEx object for searching
              Set objRegExp = New RegExp
          
              ' Search email body for each pattern
              For i = 0 To UBound(arrPatterns)
                  objRegExp.Pattern = arrPatterns(i)
                  objRegExp.Global = False
                  Set colMatches = objRegExp.Execute(oItem.Body)
                  
                  If colMatches.Count > 0 Then ' If there is a match, continue...
                      
                      Set objMatch = colMatches.Item(0)
                      strMatch = objMatch.Value
                 
                      ' some of the pattern matches require transformation
                      ' if the match is one of the patterns below, apply the listed replacement
                      
                      Select Case objRegExp.Pattern
                      
                      ' Note, for located date/time, it's only going to match one of the two patterns below, not both
                      ' That's why they have the same column assignment
                      Case "\d{2}/\d{2}/\d{4}\s\d{2}:\d{2}:\d{2}\sGMT"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "A"
                      
                      Case "\bUnable\sto\sobtain\sposition\sinformation\b"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "A"
          
                      Case "\d{7}"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "B"
                      
                      Case "X{10}[A-WYZ0-9]+"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "C"
                      
                      Case "X{6}\d{4}"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "D"
                      
                      Case "(Confidence\sLevel(\s)+)(\d{2,3})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$3", False)
                      strCol = "E"
                      
                      ' Note, for latitude, it's only going to match one of the two patterns below, not both
                      ' That's why they have the same column assignment
                      ' Latitude (north = suffix)
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})N"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2$3$4", False)
                      strCol = "F"
                      GotCoords = "Y" ' Use this to determine whether to write the hyperlink below (don't write unless there are coords)
          
                      ' Latitude (north = prefix)
                      Case "N(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$1.$2", False)
                      strCol = "F"
                      GotCoords = "Y" ' Use this to determine whether to write the hyperlink below (don't write unless there are coords)
                      
                      ' Note, for longitude, it's only going to match one of the two patterns below, not both
                      ' That's why they have the same column assignment
                      ' Longitude (west = suffix)
                      Case "(\d{2,3})\s(\d{2,3})\s(\d{2,3})\.(\d{2,3})W"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2$3$4", False)
                      strCol = "G"
                      GotCoords = "Y" ' Use this to determine whether to write the hyperlink below (don't write unless there are coords)
                      
                      ' Longitude (west = suffix)
                      Case "W(\d{2})\.(\d{5,})"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "-$1.$2", False)
                      strCol = "G"
                      GotCoords = "Y" ' Use this to determine whether to write the hyperlink below (don't write unless there are coords)
                      
                      Case "\d{1,4}\smeter(s)?\b"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "H"
                      
                      Case "\b\d\w-\w{4}\b"
                      strReplace = strMatch ' no replacement or transformation
                      strCol = "I"
                                                          
                      Case "(Sent:\s)(.*(A|P)M)"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$2", False)
                      strCol = "J"
                                  
                      Case "(Initiated\s)(\d{4}/\d{2}/\d{2}\s\d{2}:\d{2}:\d{2}\s.*)"
                      strReplace = RegExpReplace(objMatch.Value, objRegExp.Pattern, "$2", False)
                      strCol = "K"
                                                                                  
                      Case Else
                      strReplace = strMatch ' If none of the above replacement patterns match, just insert the original match into Excel
                       
                      End Select
          
                  End If
                  
                      objSheet.Cells(intRow, strCol).Value = strReplace ' Do the insert
                      ' this just adds a calculated value in the rightmost column
              Next
                      
                      If GotCoords = "Y" Then
                          ' build hyperlink to Google Maps
                          lat_coords = Cells(intRow, "F").Value
                          long_coords = Cells(intRow, "G").Value
                          basepath = "https://www.google.com/webhp?ie=UTF-8#q="
                          link_name = "View on Google Maps"
          
                          ' insert link formula for the row
                          objSheet.Cells(intRow, "L").Value = "=HYPERLINK(""" & basepath & lat_coords & "," & long_coords & """,""" & link_name & """)"
                          GotCoords = "N" ' reset
                      End If
               
              ' Save updated Excel file
              objMaster.Save
              objMaster.Close SaveChanges:=True
              If bXStarted Then
                  objExcel.Quit
              End If
              
              ' Release objects
              Set objRegExp = Nothing
              Set objSheet = Nothing
              Set objMaster = Nothing
              Set objExcel = Nothing
                
          End Sub
          

          Open in new window

          0
          Jim MAuthor Commented:
          Thanks for your help
          0
          It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
          Regular Expressions

          From novice to tech pro — start learning today.