VBA code help please...

Krucifire

Board Regular
Joined
Nov 8, 2007
Messages
96
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
ABCDEFGHIJKL
1
2
3
4
5AIRCONCARPETSDOORSELECTRICALHWSHW24KITCHENPLUMBINGRWTSHEDS
6BelconnenACTYesYesYesYesYesNoYesNoNoYes
7FyshwickACTYesYesYesYesYesNoYesNoNoYes
8TuggeranongACTYesYesYesYesYesNoYesNoNoYes
9AlburyNSWYesYesNoYesNoNoNoNoNoNo
10ArtarmonNSWYesYesYesYesYesNoYesYesYesNo
11AshfieldNSWYesYesYesYesYesNoYesYesYesYes
12AuburnNSWYesYesYesYesYesNoYesYesYesYes
13BallinaNSWYesNoYesNoNoNoYesNoYesYes
14BankstownAirportNSWYesYesYesYesYesNoYesYesYesYes
15BatemansBayNSWNoNoYesNoYesNoYesYesYesYes
16BathurstNSWNoYesYesNoYesNoYesYesYesYes
17BelmontNSWYesYesYesYesYesNoYesYesYesYes
18BelroseNSWYesYesYesYesYesNoYesYesYesNo
19BlacktownNSWYesYesNoYesYesNoYesYesYesNo
20BonnyriggNSWYesYesYesYesNoNoYesNoYesYes
Sheet1
Coverage_Tool.xls
ABCDEFGHIJKL
1ContactTypeCompanyStateProductCategoriesCoverageRegion-ACTCoverageRegion-NSWCoverageRegion-NTCoverageRegion-QLDCoverageRegion-SACoverageRegion-VICCoverageRegion-TASCoverageRegion-WA
2ActiveTradeOperatorArgyleRefrigeration(99990356)ACTAirconditioningBelconnen;#Fyshwick;#Tuggeranong
3ActiveTradeOperatorCurveJoinery(99990349)ACTKitchensBelconnen;#Fyshwick;#Tuggeranong
4ActiveTradeOperatorCustomHomeMaintenance(99990027)ACTPergolas;#Doors;#Tiling;#PoolFencing;#ShedsBelconnen;#Fyshwick;#Tuggeranong
5ActiveTradeOperatorQProjects(99990324)ACTKitchens;#Pergolas;#Doors;#TimberFlooring;#Sheds;#GeneralHandyman(ClothesLine)Belconnen;#Fyshwick;#Tuggeranong
6ActiveTradeOperatorWoodsElectricalServices(99990094)ACTHWS-ElectricOnly;#ElectricalBelconnen;#Fyshwick;#Tuggeranong
7ActiveTradeOperatorA&KFencing(99990197)NSWPoolFencing;#Sheds;#GeneralHandyman(ClothesLine)ErinaNorth;#Gosford;#Tuggerah
8ActiveTradeOperatorAableCarpetServicesNSWCarpetsArtarmon;#Belrose;#Chatswood;#Gordon;#Thornleigh;#WarringahMall
9ActiveTradeOperatorAbelRefrigeration(99990198)NSWAirconditioning;#ElectricalShellharbour;#Unanderra;#Warrawong;#Wollongong
10ActiveTradeOperatorAcademyPlumbing(99990106)NSW24hrHWS(Gas&Electric);#HWS-All;#Plumbing;#RWTBelmont;#Cardiff;#Cessnock;#Glendale;#Gosford;#Kotara;#Maitland;#Tuggerah
11ActiveTradeOperatorActiveAir&Electrical(99990199)NSWAirconditioning;#ElectricalAlbury;#WaggaWagga
Sheet2
Coverage_Tool.xls
ABCDEFGHIJ
58ActiveTradeOperatorSJ&LADaniel(99990237)NSWCarpetsAlburyWodongaNorth;#Wodonga
Sheet2
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Forum statistics

Threads
1,213,490
Messages
6,113,957
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top