如何为Excel培训矩阵的VBA宏创建循环优化代码

你的问题核心是重复编写了数百个结构完全一致的If块，导致VBA过程体积超标。下面是遵循DRY（Don't Repeat Yourself）原则的优化方案，一次编写即可适配所有现有及新增行，无需后续修改代码：

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim rowNum As Long
    Dim wsData As Worksheet
    Dim wsReport As Worksheet
    
    ' 定义工作表对象，避免反复调用Sheets，提升效率
    Set wsData = ThisWorkbook.Sheets("Data Table")
    Set wsReport = ThisWorkbook.Sheets("Report")
    
    ' 获取点击的超链接所在行号（假设超链接都在A列）
    rowNum = Target.Range.Row
    
    ' 清空Report工作表原有数据（可选，根据需求保留）
    wsReport.Range("B2:E1500").ClearContents
    wsReport.Range("A4:D1500").ClearContents
    
    ' 复制A-E列的人员信息到Report的B2位置
    wsData.Range("A" & rowNum & ":E" & rowNum).Copy Destination:=wsReport.Range("B2")
    
    ' 复制并转置固定行的数据到Report对应列
    wsData.Range("F3:BAA3").Copy
    wsReport.Range("A4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
    
    wsData.Range("F1:BAA1").Copy
    wsReport.Range("B4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
    
    wsData.Range("F2:BAA2").Copy
    wsReport.Range("C4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
    
    ' 复制当前行的F-BAA列数据并转置到Report的D列
    wsData.Range("F" & rowNum & ":BAA" & rowNum).Copy
    wsReport.Range("D4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
    
    ' 删除D列空行，避免Select操作提升性能
    On Error Resume Next ' 防止没有空行时报错
    wsReport.Range("D4:D1500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    ' 取消复制模式
    Application.CutCopyMode = False
End Sub

关键优化点说明： #

• 动态获取行号：通过Target.Range.Row直接拿到点击的超链接所在行，不管新增多少行都能自动适配
• 避免冗余操作：用工作表对象变量wsData和wsReport代替反复调用Sheets()，减少代码重复同时提升运行效率
• 移除Activate/Select：直接操作单元格范围，避免界面闪烁，同时降低代码出错概率
• 统一逻辑处理：所有复制转置逻辑只写一次，用变量rowNum替换原来的固定行号（如4、5）
• 错误处理：删除空行时加入On Error Resume Next，防止没有空行时触发运行时错误

使用说明： #

直接将原有代码替换为上述代码即可，只要你的超链接都在A列（不管行号多少），点击后都会自动生成对应人员的报告。后续新增行时，只要给A列新行添加超链接，无需修改任何VBA代码。

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