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!
- Check the table column "Resource Allocated" and find the matching name in the first column of the calendar sheet.
- Check the table column "Date Allocated" and find the matching value in the first row of the calendar sheet.
- Select the cell where these intersect (the cell with a column number of "Date Allocated" and a row number of "Resource Allocated").
- Offset the column number according to a third table column, "Time of Day".
- Fill the cell with the RGB colour specified in the code.
- 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
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
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.
