Looping though list rows and pulling column data to populate a schedule on another worksheet

Question

I just started working VBA on a project within the last couple of months, and I'm stuck on [what feels like] a pretty advanced problem set where I need to iterate though each row within a table ("DataTable") and leverage different data points across columns to:

1). Locate worksheet.name ("A:A" / "Quarter Schedule");

2.) Identify the intersect ("B:B / "Range ID" & "D:D" / "Start Date") within worksheet.name ("A:A" / "Quarter Schedule");

3.) Merge intersect location by ("F:F" / "Total Days") number of cells;

4.) Attach text ("C:C" / "Status Detail") to the new range of merged cells

Current Code:

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

I can't figure out the loop or the merge portion; any help would be greatly appreciated!

Answer 1

• Always specify the worksheet when referencing a range to ensure the reliability of your code.

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

Microsoft documentation:

Range.Find method (Excel)

ListObject.ListRows property (Excel)

ListObject.ListColumns property (Excel)

Answer 2

I worked your code a bit this morning and achieved my follow-up request that ran through different named worksheets. Thank you so much for your help and providing me with additional study material.

Solution:

Sub FindScheduledEventLocation()

    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

    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
    Set schedCol = oTab.ListColumns("Quarter Schedule").Range

    For i = 1 To oTab.ListRows.Count
        Set oSht = Worksheets(schedCol.Cells(i + 1).Value)
        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
            End With
        End If
    Next i
    
End Sub