Hi All i have the following Code and sheets which does almost exactly what i need it to do. Where it falls down is where i data like in the third table where someone covers stores across two states is there a way i can alter the below code to recognise this and still display a yes result in both stores across either state?
Code:
Option Explicit
Sub PopulateTable()
'-- Constants --
Const lHeadingRow As Long = 5
Const sTableWorksheet As String = "Sheet1"
Const sDataWorksheet As String = "Sheet2"
'-- Varables --
Dim iCol As Integer, iColEnd As Integer, iPtr As Integer, iPtr1 As Integer
Dim lRow As Long, lRowEnd As Long
Dim objDictionary As Object
Dim sKey As String, sData As String
Dim sServices As String
Dim saTemp() As String, sTemp As String
Dim vaTableData() As Variant
Dim vaSharePointData() As Variant
Dim wsTable As Worksheet, wsData As Worksheet
Set wsTable = Sheets(sTableWorksheet)
Set wsData = Sheets(sDataWorksheet)
'-- Store table into array --
iColEnd = wsTable.Cells(lHeadingRow, Columns.Count).End(xlToLeft).Column
lRowEnd = wsTable.Cells(Rows.Count, "A").End(xlUp).Row
vaTableData = wsTable.Range("A" & lHeadingRow, Cells(lRowEnd, iColEnd).Address).Value
'-- Initialise Table Array --
For lRow = 2 To UBound(vaTableData, 1)
For iCol = 3 To UBound(vaTableData, 2)
vaTableData(lRow, iCol) = "No"
Next iCol
Next lRow
'-- Store Sharepoint data into array --
lRowEnd = wsData.Cells(Rows.Count, "A").End(xlUp).Row
iColEnd = wsData.Cells(1, Columns.Count).End(xlToLeft).Column
vaSharePointData = wsData.Range("A1", Cells(lRowEnd, iColEnd).Address).Value
'-- Store SharePoint data into dictionary object --
Set objDictionary = CreateObject("Scripting.Dictionary")
With objDictionary
For lRow = 1 To UBound(vaSharePointData, 1)
'-- Get services offered --
sServices = String(iColEnd - 2, "0")
For iCol = 3 To iColEnd
If InStr(LCase$(vaSharePointData(lRow, 4)), LCase$(CStr(vaTableData(1, iCol))))<> 0 Then
Mid$(sServices, iCol - 2, 1) = "1"
End If
Next iCol
'-- Get Store Names --
sTemp = ""
For iCol = 5 To UBound(vaSharePointData, 2)
sTemp = sTemp & ";" & Trim$(Replace(CStr(vaSharePointData(lRow, iCol)), "#", ""))
Next iCol
saTemp = Split(sTemp, ";")
For iPtr = 0 To UBound(saTemp)
sKey = LCase$(saTemp(iPtr) & ";" & CStr(vaSharePointData(lRow, 3)))
If .exists(sKey) = False Then .Add sKey, String(iColEnd - 2, "0")
sData = .Item(sKey)
For iPtr1 = 1 To Len(sData)
If Mid$(sServices, iPtr1, 1) = "1" Then Mid$(sData, iPtr1, 1) = "1"
Next iPtr1
.Item(sKey) = sData
Next iPtr
Next lRow
End With
'-- Now loop thru table, setting appropriate cells to 'Yes' --
For lRow = 2 To UBound(vaTableData, 1)
sKey = LCase$(vaTableData(lRow, 1) & ";" & vaTableData(lRow, 2))
If objDictionary.exists(sKey) Then
sData = objDictionary.Item(sKey)
For iPtr = 1 To Len(sData)
If Mid$(sData, iPtr, 1) = "1" Then vaTableData(lRow, iPtr + 2) = "Yes"
Next iPtr
End If
Next lRow
'-- Write table back to sheet --
lRowEnd = UBound(vaTableData, 1) + lHeadingRow - 1
wsTable.Range("A" & lHeadingRow, Cells(lRowEnd, iColEnd).Address).Value = vaTableData
Set objDictionary = Nothing
End Sub
Coverage_Tool.xls | ||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | |||
1 | ||||||||||||||
2 | ||||||||||||||
3 | ||||||||||||||
4 | ||||||||||||||
5 | AIRCON | CARPETS | DOORS | ELECTRICAL | HWS | HW24 | KITCHEN | PLUMBING | RWT | SHEDS | ||||
6 | Belconnen | ACT | Yes | Yes | Yes | Yes | Yes | No | Yes | No | No | Yes | ||
7 | Fyshwick | ACT | Yes | Yes | Yes | Yes | Yes | No | Yes | No | No | Yes | ||
8 | Tuggeranong | ACT | Yes | Yes | Yes | Yes | Yes | No | Yes | No | No | Yes | ||
9 | Albury | NSW | Yes | Yes | No | Yes | No | No | No | No | No | No | ||
10 | Artarmon | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | No | ||
11 | Ashfield | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | Yes | ||
12 | Auburn | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | Yes | ||
13 | Ballina | NSW | Yes | No | Yes | No | No | No | Yes | No | Yes | Yes | ||
14 | BankstownAirport | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | Yes | ||
15 | BatemansBay | NSW | No | No | Yes | No | Yes | No | Yes | Yes | Yes | Yes | ||
16 | Bathurst | NSW | No | Yes | Yes | No | Yes | No | Yes | Yes | Yes | Yes | ||
17 | Belmont | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | Yes | ||
18 | Belrose | NSW | Yes | Yes | Yes | Yes | Yes | No | Yes | Yes | Yes | No | ||
19 | Blacktown | NSW | Yes | Yes | No | Yes | Yes | No | Yes | Yes | Yes | No | ||
20 | Bonnyrigg | NSW | Yes | Yes | Yes | Yes | No | No | Yes | No | Yes | Yes | ||
Sheet1 |
Coverage_Tool.xls | ||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | |||
1 | ContactType | Company | State | ProductCategories | CoverageRegion-ACT | CoverageRegion-NSW | CoverageRegion-NT | CoverageRegion-QLD | CoverageRegion-SA | CoverageRegion-VIC | CoverageRegion-TAS | CoverageRegion-WA | ||
2 | ActiveTradeOperator | ArgyleRefrigeration(99990356) | ACT | Airconditioning | Belconnen;#Fyshwick;#Tuggeranong | |||||||||
3 | ActiveTradeOperator | CurveJoinery(99990349) | ACT | Kitchens | Belconnen;#Fyshwick;#Tuggeranong | |||||||||
4 | ActiveTradeOperator | CustomHomeMaintenance(99990027) | ACT | Pergolas;#Doors;#Tiling;#PoolFencing;#Sheds | Belconnen;#Fyshwick;#Tuggeranong | |||||||||
5 | ActiveTradeOperator | QProjects(99990324) | ACT | Kitchens;#Pergolas;#Doors;#TimberFlooring;#Sheds;#GeneralHandyman(ClothesLine) | Belconnen;#Fyshwick;#Tuggeranong | |||||||||
6 | ActiveTradeOperator | WoodsElectricalServices(99990094) | ACT | HWS-ElectricOnly;#Electrical | Belconnen;#Fyshwick;#Tuggeranong | |||||||||
7 | ActiveTradeOperator | A&KFencing(99990197) | NSW | PoolFencing;#Sheds;#GeneralHandyman(ClothesLine) | ErinaNorth;#Gosford;#Tuggerah | |||||||||
8 | ActiveTradeOperator | AableCarpetServices | NSW | Carpets | Artarmon;#Belrose;#Chatswood;#Gordon;#Thornleigh;#WarringahMall | |||||||||
9 | ActiveTradeOperator | AbelRefrigeration(99990198) | NSW | Airconditioning;#Electrical | Shellharbour;#Unanderra;#Warrawong;#Wollongong | |||||||||
10 | ActiveTradeOperator | AcademyPlumbing(99990106) | NSW | 24hrHWS(Gas&Electric);#HWS-All;#Plumbing;#RWT | Belmont;#Cardiff;#Cessnock;#Glendale;#Gosford;#Kotara;#Maitland;#Tuggerah | |||||||||
11 | ActiveTradeOperator | ActiveAir&Electrical(99990199) | NSW | Airconditioning;#Electrical | Albury;#WaggaWagga | |||||||||
Sheet2 |
Coverage_Tool.xls | ||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | |||
58 | ActiveTradeOperator | SJ&LADaniel(99990237) | NSW | Carpets | Albury | WodongaNorth;#Wodonga | ||||||
Sheet2 |