VBA匹配函数和嵌套循环故障排除

Question

我有两张纸。一个是表，包含我想输入到另一个中的数据。另一个看起来几乎像甘特图，名字在侧面，日期在顶部(见这里(。

我希望程序以下面指定的方式运行，但按原样运行，它会返回：

运行时错误"438"：

对象不支持此属性或方法

上

For Each Row1 In Resource

我已经尝试了各种修复，但每次调整一个错误时，我似乎都会导致另一个错误！

---

1. 选中表列"资源分配"，并在日历表的第一列中找到匹配的名称。
2. 检查表格列"分配日期"，并在日历表的第一行中找到匹配的值。
3. 选择它们相交的单元格(列号为"分配日期"和行号为"已分配资源"的单元格(。
4. 根据第三个表列"时间"偏移列号。
5. 用代码中指定的 RGB 颜色填充单元格。
6. 对每一行重复此操作。

<小时 />

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

我已经在您的代码中做了一些重大更改。在这种情况下，Match函数效果不佳，我认为使用Find方法会给你更好的响应。看看这些变化：

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

Answer 2

作为一个想法：虽然肯定有一种方法可以循环列表对象，但以下内容可能更接近您的需求：

• 保留列表对象
• 将其读入Recordset对象
• 循环Recordset而不是列表对象

这。。。

• 消除对大多数对象变量的需求
• 使代码更具可读性(恕我直言(，因为您可以使用文字Field.Names
• 可调整到包含数据的任何范围，而不是固定为ListObjects

下面是如何使用记录集的示例：

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

笔记：

• 您不必为不同的列分配对象变量，而是可以使用YourRecordsetObject!YourColumn或(在With内(一个简单的!YourColumn来检索值。
• 您可以在循环之前进行过滤，这可能是If ... Then ... Else的替代方法并加快您的流程

希望这有帮助。