如何为此 VBA 宏创建循环？

Question

我有一个训练矩阵，我希望能够单击每个人的名字，然后它将他们的行复制到单独的工作表上的报告样式格式中。

我发现了一些有用的东西，但由于我根本不是程序员，我一直在为 Excel 表中的每一行复制并粘贴相同的代码行...我意识到有更好的方法来做到这一点，但我不知道怎么做。我想我可以摆脱它，直到遇到“程序太大”错误。

目前，我将每个人的姓名设置为文档（A1）中单元格的链接，然后我有以下代码：

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    If Target.Range.Address = "$A$4" Then
       Sheets("Report").Activate
       Sheets("Data Table").Range("A4:E4").Copy Destination:=Sheets("Report").Range("B2")
       Sheets("Data Table").Range("F3:BAA3").Copy
       Sheets("Report").Range("A4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F1:BAA1").Copy
       Sheets("Report").Range("B4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F2:BAA2").Copy
       Sheets("Report").Range("C4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F4:BAA4").Copy
       Sheets("Report").Range("D4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Report").Range("D4:D1500").Select
       Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    If Target.Range.Address = "$A$5" Then
       Sheets("Report").Activate
       Sheets("Data Table").Range("A5:E5").Copy Destination:=Sheets("Report").Range("B2")
       Sheets("Data Table").Range("F1:BAA1").Copy
       Sheets("Report").Range("B4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F3:BAA3").Copy
       Sheets("Report").Range("A4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F2:BAA2").Copy
       Sheets("Report").Range("C4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F5:BAA5").Copy
       Sheets("Report").Range("D4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Report").Range("D4:D1500").Select
       Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
End Sub

您会注意到每个块中唯一的变化是“If”范围以及第一个和第四个数据表范围，每次增加一个。我总共有 212 行，并且将来会添加更多。

我想要一些能够更有效地完成相同事情的东西（比如循环），并且希望在添加另一个人时不需要修改！我感觉这很有可能，而且没有我想象的那么难，但正如我所说，我绝对不是程序员。

任何遵循 DRY 理念的帮助将不胜感激！ =)

-大卫

TLDR：我尝试放入 212 个 if 语句，但在大约 70 个条目时它停止工作，过程太大了。我想我会在这里问我如何编写一个循环，然后我自己尝试将它分成 3 个类似的过程......

Answer 1

类似这样的：

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim rw As Range, ws As Worksheet
    
    Set rw = Target.EntireRow 'the row with the clicked link
    Set ws = ThisWorkbook.Worksheets("Report")
    
    CopyValues rw.Range("A1:E1"), ws.Range("B2") 'note Range is *relative* to `rw`
    
    CopyValues rw.Range("F1:BAA1"), ws.Range("B4"), True 'True=Transpose
    CopyValues rw.Range("F2:BAA2"), ws.Range("C4"), True
    CopyValues rw.Range("F3:BAA3"), ws.Range("A4"), True
    
    CopyValues rw.Range("F1:BAA1"), ws.Range("D4"), True
    
    ws.Range("D4:D1500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
End Sub

'copy values between `rngSrc` and `rngDest`, with optional Transpose (defaults to False)
'  Note: Transpose has an upper limit of about 65k cells....
Sub CopyValues(rngSrc As Range, rngDest As Range, Optional Transpose As Boolean = False)
    With rngSrc
        If Transpose Then
            rngDest.Cells(1).Resize(.Columns.Count, .Rows.Count).Value = Application.Transpose(.Value)
        Else
            rngDest.Cells(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
        End If
    End With
End Sub

Answer 2

如果目标位于A列且行号在4到100之间（根据需要更新），将执行复制/粘贴。

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim c As Range
    Set c = Target.Range
    If c.Column = 1 And (c.Row >= 4 And c.Row <= 100) Then
       Sheets("Report").Activate
       Sheets("Data Table").Range("A" & c.Row).Resize(1, 5).Copy Destination:=Sheets("Report").Range("B2")
       Sheets("Data Table").Range("F3:BAA3").Copy
       Sheets("Report").Range("A4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F1:BAA1").Copy
       Sheets("Report").Range("B4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F2:BAA2").Copy
       Sheets("Report").Range("C4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Data Table").Range("F4:BAA4").Copy
       Sheets("Report").Range("D4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Report").Range("D4:D1500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
End Sub