VBA Match Function & Nested For Loops Troubleshoot

Question

I have two sheets. One is a table and contains data that I want entered into the other. The other looks almost like a gantt chart, with names down the side and dates across the top (see here).

I want the program to run in the manner specified below but run as is, it returns:

Run-time error '438':

Object doesn't support this property or method

on

For Each Row1 In Resource

I have attempted various fixes but each time I adjust one error, I seem to cause another!

---

1. Check the table column "Resource Allocated" and find the matching name in the first column of the calendar sheet.
2. Check the table column "Date Allocated" and find the matching value in the first row of the calendar sheet.
3. Select the cell where these intersect (the cell with a column number of "Date Allocated" and a row number of "Resource Allocated").
4. Offset the column number according to a third table column, "Time of Day".
5. Fill the cell with the RGB colour specified in the code.
6. Repeat for every row.

---

Option Explicit

Sub CalendarSync()

Sheets("Log").Select

Dim Resource As ListColumn
Dim Dates As ListColumn
Dim ToD As ListColumn
Dim Row1 As ListRow
Dim Row2 As ListRow
Dim Row3 As ListRow

Set Resource = ActiveSheet.ListObjects("Table1").ListColumns("Resource Allocated")
Set Dates = ActiveSheet.ListObjects("Table1").ListColumns("Date Allocated")
Set ToD = ActiveSheet.ListObjects("Table1").ListColumns("Time of Day")

Dim ResMatch As Variant
Dim DateMatch As Variant

For Each Row1 In Resource
    'Cross Referencing Dates & Resources Allocated
    ResMatch = Application.Match(Resource, Worksheets("Calendar").Columns(1), 0)
    For Each Row2 In Dates
        DateMatch = Application.Match(Dates, Worksheets("Calendar").Rows(1), 0)
        'Offsetting to Account for Time of Day
        For Each Row3 In ToD
            If ToD = "PM" Then
                DateMatch.ColumnOffset (1)
            End If
            If ToD = "EVE" Then
                DateMatch.ColumnOffset (1)
            End If
'Fill the Cell
Range(ResMatch, DateMatch).Interior.Color = RGB(244, 66, 182)
        Next Row3
    Next Row2
Next Row1

End Sub

Answer 1

As a thought: while there certainly is a way to loop over your list object, the following might be closer to what you need:

• keep the list-object
• read it into a Recordset-object
• loop the Recordset instead of the list-object

This...

• erases the need for most of your object variables
• makes for more readable code (imho), since you can use literal Field.Names
• is adjustable to any range containing data, instead of being fixed to ListObjects

Here's an example of how to use a recordset:

Option Explicit

Sub testrecordset()

    Dim lo As Object
    Set lo = ThisWorkbook.Sheets(1).ListObjects("LObject1")

    ' See the f
    With GetRecordset(lo.Range)

        ' get all data
        ' ThisWorkbook.Sheets(2).Cells(2, 1).CopyFromRecordset rs

        ' get number of records
        Debug.Print .RecordCount

        ' add filter
        ' .Filter = "[Resource Allocated] = 1"

        ' clear filter
        ' .Filter = vbNullString

        ' get headers
        ' Dim i As Integer: i = 1
        ' Dim fld As Object
        ' For Each fld In .Fields
        '    ThisWorkbook.Sheets(2).Cells(1, i).Value = fld.Name
        '    i = i + 1
        ' Next fld

        ' Loop Records/Rows
        While Not .EOF
            'Debug.Print !FirstName & vbTab & !IntValue
            .MoveNext
        Wend
    End With
End Sub


' This function will return the data of a range in a recordset
Function GetRecordset(rng As Range) As Object

    'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/

    Dim xlXML As Object
    Dim rst As Object

    Set rst = CreateObject("ADODB.Recordset")
    Set xlXML = CreateObject("MSXML2.DOMDocument")
    xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML)

    rst.Open xlXML

    Set GetRecordset = rst

End Function

Notes:

• you don't have to assign object variables for the different columns, instead you can use YourRecordsetObject!YourColumn or (inside a With) a simple !YourColumn to retrieve the value.
• you can filter prior to looping, which might be an alternative to If ... Then ... Else and speed up your process

Hope this helps.

Answer 2

I've done some significal changes in your code. The Match function does not work very well in this case, I think using the Find method gives you a better response. Have a look on these changes:

Option Explicit

Sub CalendarSync()

    Dim Resource As Range
    Dim Dates As Range
    Dim ToD As Range
    Dim DateRow As Range
    Dim DateCol As Range
    Dim lCol As Range
    Dim Row1 As Range
    Dim Row2 As Range
    Dim Row3 As Range
    Dim Range As Range
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet

    Set sh1 = ThisWorkbook.Sheets("Log")
    Set sh2 = ThisWorkbook.Sheets("Calendar")

    Set Resource = sh1.ListObjects("Table1").ListColumns("Resource Allocated").Range
    Set Dates = sh1.ListObjects("Table1").ListColumns("Date Allocated").Range
    Set ToD = sh1.ListObjects("Table1").ListColumns("Time of Day").Range
    Set lCol = sh2.Cells(1, sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2)
    Set DateRow = sh2.Range("A1", lCol)  'Set the row range of your dates
    Set DateCol = sh2.Range("A1", sh2.Range("A" & Rows.Count).End(xlUp)) 'Set the column range of your resources

    Dim ResMatch As Range
    Dim DateMatch As Range

    For Each Row1 In Resource
        'Find the Resource match in column
        Set ResMatch = DateCol.Find(What:=Row1, LookIn:=xlValues)
        If Not ResMatch Is Nothing Then 'If has found then

            'Find the Date match in row
            Set Row2 = Row1.Offset(0, 1)
            Set DateMatch = DateRow.Find(What:=Row2, LookIn:=xlValues)
            If Not DateMatch Is Nothing Then 'If has found then

                Set Row3 = Row1.Offset(0, 2)

                If Row3 = "PM" Then
                    Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column).Offset(0, 1)
                ElseIf Row3 = "EVE" Then
                    Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column).Offset(0, 2)
                Else
                    Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column)
                End If

                Range.Interior.Color = RGB(244, 66, 182)

            End If

        End If
    Next Row1
End Sub