VBA实现Excel Schedule与Cables Detailed工作表数据联动操作求助

需求背景 #

本人是VBA使用新手，花费大量时间观看视频、查阅在线PDF等资料仍无进展，现附两份通用数据截图辅助说明需求。我尝试过使用录制宏功能，但该功能无法实现这类复杂操作。我之前有一定MATLAB编程基础，但对VBA掌握度不高，需要能够实现对应功能的代码，以及适用的学习指引。

附件截图 #

功能要求 #

• 查找Schedule工作表中所有标注为'Install'的单元格
• 向左偏移一格获取该Install对应的线缆名称
• 在Cables Detailed工作表中搜索匹配该线缆名称
• 统计Cables Detailed工作表中对应名称的线缆条目总数
• 在Schedule工作表中对应线缆名称的下方插入与条目数相等的新行，例如Cable D需在下方插入4个新行
• 将Cables Detailed工作表中对应线缆的第2、3、4项数据填入Schedule工作表的新增单元格中
• 遍历所有'Install'实例，重复执行上述操作
• 程序需兼容处理遇到'Install'但Cables Detailed工作表中无对应数据的场景

实现代码 #

Sub 填充线缆明细数据()
    Dim schSht As Worksheet, detSht As Worksheet
    Dim findRng As Range, installCell As Range, detFind As Range
    Dim cableName As String, matchCnt As Long, i As Long
    Dim detStartRow As Long, firstAdd As String
    
    ' 绑定对应工作表，可根据实际表名修改
    Set schSht = ThisWorkbook.Sheets("Schedule")
    Set detSht = ThisWorkbook.Sheets("Cables Detailed")
    
    ' 关闭屏幕更新提升运行效率
    Application.ScreenUpdating = False
    
    ' 查找Schedule表中所有值为"Install"的单元格
    Set findRng = schSht.UsedRange.Find(What:="Install", LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not findRng Is Nothing Then
        firstAdd = findRng.Address
        Do
            Set installCell = findRng
            ' 左移1列获取对应线缆名称
            cableName = installCell.Offset(0, -1).Value
            ' 统计明细页匹配线缆的总条目数
            matchCnt = Application.WorksheetFunction.CountIf(detSht.Columns("A"), cableName)
            
            ' 仅当有匹配条目时执行插入和填充操作
            If matchCnt > 0 Then
                ' 在线缆所在行下方插入对应数量的空行
                installCell.Offset(1, 0).Resize(matchCnt, 1).EntireRow.Insert Shift:=xlDown
                ' 定位明细页第一个匹配线缆的行号
                Set detFind = detSht.Columns("A").Find(What:=cableName, LookIn:=xlValues, LookAt:=xlWhole)
                detStartRow = detFind.Row
                ' 批量填充明细数据，默认提取明细页B/C/D列，可自行修改列号
                For i = 0 To matchCnt - 1
                    installCell.Offset(i + 1, -1).Value = detSht.Cells(detStartRow + i, "B").Value
                    installCell.Offset(i + 1, 0).Value = detSht.Cells(detStartRow + i, "C").Value
                    installCell.Offset(i + 1, 1).Value = detSht.Cells(detStartRow + i, "D").Value
                Next i
            End If
            ' 查找下一个"Install"单元格
            Set findRng = schSht.UsedRange.FindNext(findRng)
        Loop While Not findRng Is Nothing And findRng.Address <> firstAdd
    End If
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "数据处理完成"
End Sub

使用说明 #

• 运行代码前请先备份原Excel文件，避免操作失误导致数据丢失
• 代码默认Cables Detailed表中线缆名称存储在A列，需提取的第2、3、4项对应B、C、D列，若你的实际表格列位置不同，修改代码中对应列号即可
• 如需学习VBA相关知识，可参考Office官方文档中Range对象、工作表操作、查找方法相关章节

内容的提问来源于stack exchange，提问作者bondu