循环列表行并提取列数据以填充另一个工作表上的计划

Question

我在过去几个月内刚刚开始在一个项目上使用 VBA，并且我陷入了[感觉像是]一个非常高级的问题集，我需要迭代表（“DataTable”）中的每一行并利用跨列的不同数据点来查找工作表（“A：A”），识别相交（“B：B＆“D：D”），按单元格数量（“F：F”）合并相交位置，然后附加文本（“E：E”）到新的单元格区域。

当前代码：

Sub FindCellLocations()

Application.ScreenUpdating = False

    Dim FoundCol As Range
    Dim FoundRow As Range
        
    Set FoundCol = Range("6:6").Find(what:=Sheets("Data Table").Range("DataTable[Start Date]").Value, LookIn:=xlFormulas)
    Set FoundRow = Range("A:A").Find(what:=Sheets("Data Table").Range("DataTable[Range ID]").Value)
    Set x = Intersect(FoundCol.EntireColumn, FoundRow.EntireRow)
        
        If x Is Nothing Then
            MsgBox "Ranges don't intersect"
          Else
            With x.Resize(, 3)
                .Merge Across:=True
                .Value = Sheets("Data Table").Range("DataTable[Status Detail]").Value
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = vbYellow
            End With
        End If
        
End Sub

我无法弄清楚循环或合并部分；任何帮助将不胜感激！

Answer 1

• 引用范围时始终指定工作表，以确保代码的可靠性。

Option Explicit
Sub FindCellLocations()
    Dim oTab As ListObject, i As Long
    Dim dateCol As Range, idCol As Range
    Dim daysCol As Range, statusCol As Range
    Dim foundCol As Range, foundRow As Range
    Dim oSht As Worksheet
    Application.ScreenUpdating = False
    'Sheet SPACE FOR LEGEND, modify sheet name as needed
    Set oSht = Sheets("Legend")
    ' Get data table (ListObject)
    Set oTab = Sheets("Data Table").ListObjects("DataTable")
    Set dateCol = oTab.ListColumns("Start Date").Range
    Set idCol = oTab.ListColumns("Range ID").Range
    Set statusCol = oTab.ListColumns("Status Detail").Range
    Set daysCol = oTab.ListColumns("Total Days").Range
    ' Loop through data
    For i = 1 To oTab.ListRows.Count
        Set foundCol = oSht.Range("6:6").Find(what:=dateCol.Cells(i + 1), LookIn:=xlFormulas, lookAt:=xlWhole)
        Set foundRow = oSht.Range("A:A").Find(what:=idCol.Cells(i + 1), LookIn:=xlFormulas, lookAt:=xlWhole)
        If Not (foundCol Is Nothing Or foundRow Is Nothing) Then
            With oSht.Cells(foundRow.Row, foundCol.Column)
                .Resize(, daysCol.Cells(i + 1)).Merge Across:=True
                .Value = statusCol.Cells(i + 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = vbYellow
            End With
        End If
    Next i
End Sub

微软文档：

范围.查找方法（Excel）

ListObject.ListRows 属性 (Excel)

ListObject.ListColumns 属性 (Excel)