Question

我有两张纸。一个是表，包含我想要输入另一个的数据。另一个看起来几乎像一个甘特图，名字在旁边，日期在顶部（见here）。

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

运行时错误＆＃39;＆＃39;＆＃39;
：

对象不支持此属性或方法

on

For Each Row1 In Resource

我尝试了各种修正，但每次调整一个错误时，我似乎都会引起另一个错误！

检查表格列＆＃34;资源已分配＆＃34;并在日历表的第一列中找到匹配的名称。
检查表格列＆＃34;日期分配＆＃34;并在日历表的第一行中找到匹配值。
选择相交的单元格（列号为＆＃34的单元格;分配日期＆＃34;行号为＆＃34;资源已分配＆＃34;）。
根据第三个表格列抵消列号，＆＃34;时间＆＃34 ;.
使用代码中指定的RGB颜色填充单元格。
重复每一行。

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

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

保留list-object
将其读入Recordset - 对象
循环Recordset而不是list-object

此...

消除了对大多数对象变量的需求
提供更易读的代码（imho），因为您可以使用文字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的替代方案并加快您的流程

希望这有帮助。

Answer 2

我在您的代码中做了一些重大更改。在这种情况下，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

VBA比赛功能＆amp;嵌套用于循环故障排除

2 个答案: