VBA匹配function和嵌套循环查错

我有两张床单。 一个是表格 ，包含我想要input到另一个的数据。 另一个看起来就像是一张甘特图，名字倒在旁边，可以看到顶部（见这里 ）。

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

运行时错误“438”：

对象不支持这个属性或方法

上

For Each Row1 In Resource 

我尝试了各种修复，但每次我调整一个错误，我似乎造成另一个！

---

1. 检查表列“分配的资源”，并在日历表的第一列中find匹配的名称。
2. 检查表格列“分配date”，并在日历表的第一行find匹配的值。
3. select这些相交的单元格（列号分别为“Date Allocated”和行号“Resource Allocated”的单元格）。
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而不是列表对象

这个…

• 消除了大部分对象variables的需求
• 使更多的可读代码（恕我直言），因为你可以使用文字Field.Names
• 可以调整到包含数据的任何范围，而不是固定在ListObjects

以下是如何使用logging集的示例：

 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 

笔记：

• 您不必为不同的列指定对象variables，而是可以使用YourRecordsetObject!YourColumn或（在With ）一个简单的!YourColumn来检索值。
• 您可以在循环之前进行过滤，这可能是If ... Then ... Else的替代方法， If ... Then ... Else加速您的过程

希望这可以帮助。