VBA CODES
This is the first step. This step begins when you Download the assets from Hailtrace and imports it into Reonomy. Then download that first sheet they give you when import is finished. Here is where we remove the duplicates and the addresses that are not on Reonomy, so it gives us a clean list of properties and addresses.
The sheet must be renamed to "ReonomyHailTrace"
Sub ExportOKStatusAndRemoveDuplicates()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, destRow As Long
Dim filterCols As Variant
Dim statusCol As Long, addressCol As Long
Dim colMapping As Object
Dim cell As Range, srcCol As Long, destCol As Long
Dim key As Variant
Dim statusValue As String
Dim addressDict As Object
‘ Set the worksheet to “ReonomyHailTrace”
On Error Resume Next
Set ws = ThisWorkbook.Sheets(“ReonomyHailTrace”)
On Error GoTo 0
If ws Is Nothing Then
MsgBox “Sheet ‘ReonomyHailTrace’ not found!”, vbExclamation
Exit Sub
End If
‘ Find last row in the sheet
lastRow = ws.Cells(ws.Rows.Count, “A”).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
‘ Define the columns to extract
filterCols = Array(“Address”, “City”, “State”, “Zipcode”, “Last Impact Date”, _
“Location”, “Last Meteorologist Hail Impact Date”, “Last Meteorologist Hail Impact Size”)
‘ Create dictionaries for column mapping and address tracking
Set colMapping = CreateObject(“Scripting.Dictionary”)
Set addressDict = CreateObject(“Scripting.Dictionary”) ‘ To track duplicate addresses
‘ Find column indexes for required fields
For Each cell In ws.Rows(1).Cells
If Not IsError(Application.Match(Trim(cell.Value), filterCols, 0)) Then
colMapping(Trim(cell.Value)) = cell.Column
End If
If cell.Value = “status” Then
statusCol = cell.Column
End If
If cell.Value = “Address” Then
addressCol = cell.Column
End If
Next cell
‘ Ensure “status” and “Address” columns were found
If statusCol = 0 Then
MsgBox “Lowercase ‘status’ column not found!”, vbExclamation
Exit Sub
End If
If addressCol = 0 Then
MsgBox “‘Address’ column not found!”, vbExclamation
Exit Sub
End If
‘ Create a new sheet for filtered data
On Error Resume Next
Application.DisplayAlerts = False
Sheets(“Filtered_Data”).Delete ‘ Delete existing if it exists
Application.DisplayAlerts = True
On Error GoTo 0
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = “Filtered_Data”
‘ Copy headers to new sheet
destCol = 1
For Each key In filterCols
If colMapping.exists(key) Then
newWs.Cells(1, destCol).Value = key
destCol = destCol + 1
End If
Next key
‘ Copy filtered data where status = “OK” and remove duplicate addresses
destRow = 2
For i = 2 To lastRow
statusValue = Trim(UCase(ws.Cells(i, statusCol).Value)) ‘ Normalize status value
addressValue = Trim(ws.Cells(i, addressCol).Value) ‘ Get the address value
‘ Check if row is “OK” and if the address is unique
If statusValue = “OK” Then
If Not addressDict.exists(addressValue) Then
addressDict.Add addressValue, True ‘ Store the address to prevent duplicates
destCol = 1
For Each key In filterCols
If colMapping.exists(key) Then
srcCol = colMapping(key)
newWs.Cells(destRow, destCol).Value = ws.Cells(i, srcCol).Value
destCol = destCol + 1
End If
Next key
destRow = destRow + 1 ‘ Move to next row in the new sheet
End If
End If
Next i
MsgBox “Filtered data exported successfully with duplicates removed!”, vbInformation
End Sub
This step pulls information from the "contacts" sheet for the properties that Reonomy gave and put them compiled in different rows, but keep them close for each address. On this step the data is still not organized. This step creates the sheet "UniqueContacts"
Sub ExportUniqueContacts()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, i As Long, j As Long, rowCount As Long
Dim addressParts As Variant
Dim headerCol As Range
Dim colIndex As Integer
Dim originalHeaders() As Integer
Set ws = ThisWorkbook.Sheets(1) ‘ Assume data is in the first sheet
‘ Create new sheet
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(“UniqueContacts”)
If newWs Is Nothing Then
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = “UniqueContacts”
Else
newWs.Cells.Clear
End If
On Error GoTo 0
‘ Define the headers for new sheet and their corresponding original headers
Dim headers As Variant, sourceHeaders As Variant
headers = Array(“Contact Name”, “Street Address”, “City”, “State”, “Zip Code”, _
“Company Name”, “Contact Title”, “Phone 1”, “Phone 2”, “Phone 3”, _
“Phone 4”, “Phone 5”, “Email 1”, “Email 2”, “Email 3”, _
“Email 4”, “Email 5”)
sourceHeaders = Array(“contact_name”, “subject_address_full”, “subject_address_full”, “subject_address_full”, “subject_address_full”, _
“contact_company_name”, “contact_title”, “contact_phone_1”, “contact_phone_2”, “contact_phone_3”, _
“contact_phone_4”, “contact_phone_5”, “contact_email_1”, “contact_email_2”, “contact_email_3”, _
“contact_email_4”, “contact_email_5”)
‘ Resize array to hold column positions
ReDim originalHeaders(LBound(sourceHeaders) To UBound(sourceHeaders))
‘ Write headers to the new sheet and store column positions
For i = LBound(headers) To UBound(headers)
newWs.Cells(1, i + 1).Value = headers(i)
Set headerCol = ws.Rows(1).Find(sourceHeaders(i), LookAt:=xlWhole)
If Not headerCol Is Nothing Then
originalHeaders(i) = headerCol.Column
Else
originalHeaders(i) = 0 ‘ Mark as not found
End If
Next i
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
rowCount = 2
‘ Loop through the data and copy all required columns, even if addresses are repeated
For i = 2 To lastRow
‘ Extract address components
If originalHeaders(1) <> 0 Then
addressParts = Split(ws.Cells(i, originalHeaders(1)).Value, “,”)
Else
addressParts = Split(“”, “,”) ‘ Ensure no errors occur
End If
If originalHeaders(0) <> 0 Then
newWs.Cells(rowCount, 1).Value = ws.Cells(i, originalHeaders(0)).Value ‘ Contact Name
End If
If UBound(addressParts) >= 0 Then newWs.Cells(rowCount, 2).Value = Trim(addressParts(0)) ‘ Street Address
If UBound(addressParts) >= 1 Then newWs.Cells(rowCount, 3).Value = Trim(addressParts(1)) ‘ City
If UBound(addressParts) >= 2 Then
Dim stateZip As Variant
stateZip = Split(Trim(addressParts(2)), ” “)
newWs.Cells(rowCount, 4).Value = UCase(Trim(stateZip(0))) ‘ State (Uppercase)
If UBound(stateZip) >= 1 Then newWs.Cells(rowCount, 5).Value = Trim(stateZip(1)) ‘ Zip Code
End If
‘ Copy other columns
For j = 6 To UBound(headers) + 1
If originalHeaders(j – 1) <> 0 Then
Dim cellValue As String
cellValue = ws.Cells(i, originalHeaders(j – 1)).Value
‘ Format phone numbers
If j >= 8 And j <= 12 Then ‘ Phone columns
If Len(cellValue) = 11 And Left(cellValue, 1) = “1” Then
cellValue = Mid(cellValue, 2) ‘ Remove leading 1
End If
If Len(cellValue) = 10 And IsNumeric(cellValue) Then
cellValue = Format(cellValue, “(###) ###-####”)
End If
End If
newWs.Cells(rowCount, j).Value = cellValue
End If
Next j
rowCount = rowCount + 1
Next i
MsgBox “Contact export complete, including formatting fixes!”, vbInformation
End Sub
This step compiles all of the contact information together on the same row, with multiple columns for different owners, phone numbers and emails. This steps create the sheet "Refined Data Compiled"
Sub CompileContacts()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, newRow As Long, i As Long, j As Long
Dim key As String
Dim dict As Object
‘ Ensure the “UniqueContacts” sheet is used
On Error Resume Next
Set ws = ThisWorkbook.Sheets(“UniqueContacts”)
On Error GoTo 0
If ws Is Nothing Then
MsgBox “Worksheet ‘UniqueContacts’ not found!”, vbExclamation
Exit Sub
End If
Set dict = CreateObject(“Scripting.Dictionary”)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
‘ Create new sheet for refined data
On Error Resume Next
Application.DisplayAlerts = False
Sheets(“Refined Data Compiled”).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = “Refined Data Compiled”
‘ Set headers for new sheet
Dim headers As Variant
headers = Array(“Street Address”, “City”, “State”, “Zip Code”, “Company Name”)
For i = LBound(headers) To UBound(headers)
newWs.Cells(1, i + 1).Value = headers(i)
Next i
newRow = 2
‘ Dictionary to track unique addresses
Dim contactDict As Object
Set contactDict = CreateObject(“Scripting.Dictionary”)
‘ Iterate through each row in the original sheet
For i = 2 To lastRow
key = ws.Cells(i, 2).Value & “|” & ws.Cells(i, 3).Value & “|” & ws.Cells(i, 4).Value & “|” & ws.Cells(i, 5).Value
If Not contactDict.Exists(key) Then
contactDict.Add key, newRow
newWs.Cells(newRow, 1).Value = ws.Cells(i, 2).Value ‘ Street Address
newWs.Cells(newRow, 2).Value = ws.Cells(i, 3).Value ‘ City
newWs.Cells(newRow, 3).Value = ws.Cells(i, 4).Value ‘ State
newWs.Cells(newRow, 4).Value = ws.Cells(i, 5).Value ‘ Zip Code
newWs.Cells(newRow, 5).Value = ws.Cells(i, 6).Value ‘ Company Name
newRow = newRow + 1
End If
Dim rowIndex As Integer
rowIndex = contactDict(key)
‘ Find next available contact column
j = 6
Do While newWs.Cells(rowIndex, j).Value <> “”
j = j + 8 ‘ Move to next set of contact columns
Loop
‘ Add headers dynamically
newWs.Cells(1, j).Value = “First Name ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 1).Value = “Last Name ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 2).Value = “Phone 1 ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 3).Value = “Phone 2 ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 4).Value = “Phone 3 ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 5).Value = “Email 1 ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 6).Value = “Email 2 ” & ((j – 6) / 8 + 1)
newWs.Cells(1, j + 7).Value = “Email 3 ” & ((j – 6) / 8 + 1)
‘ Separate first and last names correctly
Dim nameParts() As String
nameParts = Split(ws.Cells(i, 1).Value, ” “, 2)
If UBound(nameParts) = 1 Then
newWs.Cells(rowIndex, j).Value = nameParts(0) ‘ First Name
newWs.Cells(rowIndex, j + 1).Value = nameParts(1) ‘ Last Name
Else
newWs.Cells(rowIndex, j).Value = ws.Cells(i, 1).Value ‘ If only one name, keep as First Name
newWs.Cells(rowIndex, j + 1).Value = “”
End If
‘ Store phone numbers and emails correctly with filtering
Dim contactData As Variant, k As Integer, phoneCol As Integer, emailCol As Integer
contactData = Array(ws.Cells(i, 8).Value, ws.Cells(i, 9).Value, ws.Cells(i, 10).Value, ws.Cells(i, 11).Value, ws.Cells(i, 12).Value, ws.Cells(i, 13).Value, ws.Cells(i, 14).Value, ws.Cells(i, 15).Value)
phoneCol = j + 2
emailCol = j + 5
For k = LBound(contactData) To UBound(contactData)
If contactData(k) <> “” Then
If InStr(1, contactData(k), “@”) > 0 Then
newWs.Cells(rowIndex, emailCol).Value = contactData(k) ‘ Ensure only emails go under email columns
emailCol = emailCol + 1
ElseIf IsNumeric(Replace(Replace(Replace(contactData(k), “(“, “”), “)”, “”), “-“, “”)) Then
newWs.Cells(rowIndex, phoneCol).Value = contactData(k) ‘ Ensure only phone numbers go under phone columns
phoneCol = phoneCol + 1
End If
End If
Next k
Next i
MsgBox “Data compiled successfully!”, vbInformation
End Sub
This step is to merge the property information such as type, year built, area and etc, to the Refined Data Compiled. If you are questioning why we didn't do it directly from the properties, it's because the contacts are not as specific, therefore this merge is necessary. This step creates the sheet "Merged Data"
Sub MergeRefinedAndProperties()
Dim wsRefined As Worksheet, wsProperties As Worksheet, wsMerged As Worksheet
Dim lastRowRefined As Long, lastRowProperties As Long, lastColRefined As Long
Dim refinedDict As Object, colMapping As Object
Dim propRow As Long, refRow As Long, destRow As Long
Dim key As String, destCol As Long, companyCol As Long
Dim addressColRefined As Long, addressColProperties As Long
Dim requiredCols As Variant
Dim cell As Range, srcCol As Long
Dim i As Integer
‘ Set worksheets
On Error Resume Next
Set wsRefined = ThisWorkbook.Sheets(“Refined Data Compiled”)
Set wsProperties = ThisWorkbook.Sheets(“properties”)
On Error GoTo 0
‘ Validate sheets exist
If wsRefined Is Nothing Or wsProperties Is Nothing Then
MsgBox “One or both sheets not found!”, vbExclamation
Exit Sub
End If
‘ Find last rows and columns
lastRowRefined = wsRefined.Cells(Rows.Count, 1).End(xlUp).Row
lastRowProperties = wsProperties.Cells(Rows.Count, 1).End(xlUp).Row
lastColRefined = wsRefined.Cells(1, Columns.Count).End(xlToLeft).Column
‘ Define property columns to extract
requiredCols = Array(“link”, “owner_profile_link”, “lot_area”, “lot_frontage”, _
“lot_depth”, “floor_area_ratio”, “gross_building_area”, “total_units”, _
“total_buildings”, “total_residential_units”, “total_commercial_units”, _
“property_type”, “property_subtype”, “year_built”, “year_renovated”, “stories”)
‘ Create dictionaries for fast lookup
Set refinedDict = CreateObject(“Scripting.Dictionary”)
Set colMapping = CreateObject(“Scripting.Dictionary”)
‘ Find column indexes in properties
For Each cell In wsProperties.Rows(1).Cells
If Not IsError(Application.Match(cell.Value, requiredCols, 0)) Then
colMapping(cell.Value) = cell.Column
End If
If cell.Value = “address_line_1” Then
addressColProperties = cell.Column
End If
Next cell
‘ Find column index for “Street Address” and “Company Name” in Refined Data
For Each cell In wsRefined.Rows(1).Cells
If cell.Value = “Street Address” Then
addressColRefined = cell.Column
End If
If cell.Value = “Company Name” Then
companyCol = cell.Column
End If
Next cell
‘ Validate that address and company columns were found
If addressColProperties = 0 Or addressColRefined = 0 Or companyCol = 0 Then
MsgBox “Required columns not found in one of the sheets!”, vbExclamation
Exit Sub
End If
‘ Store property data in a dictionary
For propRow = 2 To lastRowProperties
key = Trim(UCase(wsProperties.Cells(propRow, addressColProperties).Value))
If Not refinedDict.exists(key) Then
refinedDict.Add key, propRow
End If
Next propRow
‘ Create new sheet for merged data
On Error Resume Next
Application.DisplayAlerts = False
Sheets(“Merged Data”).Delete ‘ Remove if exists
Application.DisplayAlerts = True
On Error GoTo 0
Set wsMerged = ThisWorkbook.Sheets.Add
wsMerged.Name = “Merged Data”
‘ Copy ALL data from Refined Data Compiled including formatting and hyperlinks
wsRefined.UsedRange.Copy
wsMerged.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
‘ Find the last column in Merged Data after copying
lastColRefined = wsMerged.Cells(1, Columns.Count).End(xlToLeft).Column
‘ Shift columns to the right to make space for new data
Dim totalNewCols As Integer
totalNewCols = UBound(requiredCols) – LBound(requiredCols) + 1
wsMerged.Columns(companyCol + 1).Resize(, totalNewCols).Insert Shift:=xlToRight
‘ Insert property headers beside “Company Name”
destCol = companyCol + 1
For i = LBound(requiredCols) To UBound(requiredCols)
If colMapping.exists(requiredCols(i)) Then
wsMerged.Cells(1, destCol).Value = requiredCols(i)
destCol = destCol + 1
End If
Next i
‘ Copy data row by row
destRow = 2
For refRow = 2 To lastRowRefined
key = Trim(UCase(wsRefined.Cells(refRow, addressColRefined).Value))
‘ If address is found in properties, merge data
If refinedDict.exists(key) Then
propRow = refinedDict(key)
‘ Insert property data beside “Company Name”
destCol = companyCol + 1
For i = LBound(requiredCols) To UBound(requiredCols)
If colMapping.exists(requiredCols(i)) Then
srcCol = colMapping(requiredCols(i))
wsMerged.Cells(destRow, destCol).Value = wsProperties.Cells(propRow, srcCol).Value
‘ Ensure hyperlinks remain clickable
If requiredCols(i) = “link” Or requiredCols(i) = “owner_profile_link” Then
If wsProperties.Cells(propRow, srcCol).Value <> “” Then
wsMerged.Cells(destRow, destCol).Hyperlinks.Add _
Anchor:=wsMerged.Cells(destRow, destCol), _
Address:=wsProperties.Cells(propRow, srcCol).Value, _
TextToDisplay:=wsProperties.Cells(propRow, srcCol).Value
End If
End If
destCol = destCol + 1
End If
Next i
End If
destRow = destRow + 1
Next refRow
Application.CutCopyMode = False
MsgBox “Merged data successfully created with clickable links and all property data beside Company Name!”, vbInformation
End Sub
For this step you need to upload the Hailtrace data sheet into the main database sheet you are working on, make sure it is called "Hailtrace" on the Spreadsheet. This sheet creates the final sheet called "UpdatedData".
Sub MatchAndMergeData()
Dim wsMerged As Worksheet, wsHailtrace As Worksheet, wsUpdated As Worksheet
Dim lastRowMerged As Long, lastRowHail As Long
Dim dict As Object
Dim cell As Range, addr As String
Dim matchKey As String, bestMatch As String
Dim bestScore As Integer, currentScore As Integer, threshold As Integer
‘ Set worksheets
Set wsMerged = ThisWorkbook.Sheets(“Merged Data”)
Set wsHailtrace = ThisWorkbook.Sheets(“Hailtrace”)
‘ Create new sheet for updated data
On Error Resume Next
Application.DisplayAlerts = False
Sheets(“UpdatedData”).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set wsUpdated = ThisWorkbook.Sheets.Add
wsUpdated.Name = “UpdatedData”
‘ Copy MergedData contents to UpdatedData
wsMerged.Cells.Copy wsUpdated.Cells
‘ Find last rows
lastRowMerged = wsUpdated.Cells(wsUpdated.Rows.Count, 1).End(xlUp).Row
lastRowHail = wsHailtrace.Cells(wsHailtrace.Rows.Count, 1).End(xlUp).Row
‘ Find column numbers
Dim colStreetAddr As Integer, colCompany As Integer, colAddress As Integer
Dim colImpactDate As Integer, colHailDate As Integer, colHailSize As Integer
colStreetAddr = Application.Match(“Street Address”, wsUpdated.Rows(1), 0)
colCompany = Application.Match(“Company Name”, wsUpdated.Rows(1), 0)
colAddress = Application.Match(“Address”, wsHailtrace.Rows(1), 0)
colImpactDate = Application.Match(“Last Impact Date”, wsHailtrace.Rows(1), 0)
colHailDate = Application.Match(“Last Meteorologist Hail Impact Date”, wsHailtrace.Rows(1), 0)
colHailSize = Application.Match(“Last Meteorologist Hail Impact Size”, wsHailtrace.Rows(1), 0)
‘ Shift existing columns to the right before inserting new ones
wsUpdated.Columns(colCompany + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsUpdated.Columns(colCompany + 2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsUpdated.Columns(colCompany + 3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
‘ Add column headers
wsUpdated.Cells(1, colCompany + 1).Value = “Last Impact Date”
wsUpdated.Cells(1, colCompany + 2).Value = “Last Meteorologist Hail Impact Date”
wsUpdated.Cells(1, colCompany + 3).Value = “Last Meteorologist Hail Impact Size”
‘ Store Hailtrace data in dictionary
Set dict = CreateObject(“Scripting.Dictionary”)
For Each cell In wsHailtrace.Range(wsHailtrace.Cells(2, colAddress), wsHailtrace.Cells(lastRowHail, colAddress))
matchKey = Trim(LCase(cell.Value)) ‘ Normalize address for better matching
If Not dict.exists(matchKey) Then
dict(matchKey) = Array(cell.Offset(0, colImpactDate – colAddress).Value, _
cell.Offset(0, colHailDate – colAddress).Value, _
cell.Offset(0, colHailSize – colAddress).Value)
End If
Next cell
‘ Set threshold for fuzzy matching
threshold = 3 ‘ Adjust this value if needed
‘ Match addresses and populate hail data
For Each cell In wsUpdated.Range(wsUpdated.Cells(2, colStreetAddr), wsUpdated.Cells(lastRowMerged, colStreetAddr))
addr = Trim(LCase(cell.Value)) ‘ Normalize address for lookup
If dict.exists(addr) Then
Dim dataArr As Variant
dataArr = dict(addr)
Else
‘ Fuzzy matching if exact match not found
bestScore = 99
bestMatch = “”
Dim key As Variant
For Each key In dict.keys
currentScore = LevenshteinDistance(addr, key)
If currentScore < bestScore And currentScore <= threshold Then
bestScore = currentScore
bestMatch = key
End If
Next key
If bestMatch <> “” Then
dataArr = dict(bestMatch)
End If
End If
‘ Assign values if match found
If Not IsEmpty(dataArr) Then
cell.Offset(0, colCompany – colStreetAddr + 1).Value = dataArr(0)
cell.Offset(0, colCompany – colStreetAddr + 2).Value = dataArr(1)
cell.Offset(0, colCompany – colStreetAddr + 3).Value = dataArr(2)
End If
Next cell
‘ Cleanup
Set dict = Nothing
MsgBox “Data merged successfully into ‘UpdatedData’ sheet.”, vbInformation
End Sub
Function LevenshteinDistance(ByVal s1 As String, ByVal s2 As String) As Integer
Dim i As Integer, j As Integer
Dim m As Integer, n As Integer
Dim d() As Integer
m = Len(s1)
n = Len(s2)
ReDim d(0 To m, 0 To n)
For i = 0 To m
d(i, 0) = i
Next i
For j = 0 To n
d(0, j) = j
Next j
For i = 1 To m
For j = 1 To n
If Mid(s1, i, 1) = Mid(s2, j, 1) Then
d(i, j) = d(i – 1, j – 1)
Else
d(i, j) = Application.WorksheetFunction.Min(d(i – 1, j) + 1, d(i, j – 1) + 1, d(i – 1, j – 1) + 1)
End If
Next j
Next i
LevenshteinDistance = d(m, n)
End Function