VBA匹配功能嵌套循环故障排除 [英] VBA Match Function & Nested For Loops Troubleshooting

问题描述

我有两张纸.一个是表，其中包含我要输入到另一个中的数据.另一个看上去几乎像一个甘特图，名称在旁边，日期在顶部(请参阅此处).

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:

运行时错误"438":

Run-time error '438':

对象不支持此属性或方法

Object doesn't support this property or method

上

For Each Row1 In Resource

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

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

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

推荐答案

我对您的代码进行了一些重大更改. Match函数在这种情况下不能很好地工作，我认为使用Find方法可以为您提供更好的响应.看一下这些变化:

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

这篇关于VBA匹配功能嵌套循环故障排除的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！