如何为此 VBA 宏创建循环？

像这样的东西：

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`
                                                 '  and not to the sheet
    ' `Me` is the worksheet for this code module...
    CopyValues Me.Range("F1:BAA1"), ws.Range("B4"), True 'True=Transpose
    CopyValues Me.Range("F2:BAA2"), ws.Range("C4"), True
    CopyValues Me.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

如果目标在 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("F" & c.Row).Resize(1, 1374).Copy 
       Sheets("Report").Range("D4").PasteSpecial Transpose:=True, Paste:=xlPasteValues
       Sheets("Report").Range("D4:D1500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
End Sub

工作表 FollowHyperlink：将值复制到另一个工作表

工作表模块，例如Sheet1（数据表）

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    'Debug.Print Target.Range.Address
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = Me ' Data Table
    'Set sws = Target.Range.Worksheet
    
    ' Reference the target range in the source worksheet.
    Dim trg As Range:
    Set trg = sws.Range("A4", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    ' Attempt to reference the target cell.
    Dim tCell As Range: Set tCell = Intersect(trg, Target.Range)
    If tCell Is Nothing Then Exit Sub ' no intersection (no target cell)
    
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = sws.Parent.Sheets("Report")
    'Set dws = ThisWorkbook.Sheets("Report")
    'Set dws = Target.Range.Worksheet.Parent.Sheets("Report")
    
    ' Declare variables.
    Dim srg As Range, drg As Range
    
    ' Copy 'A:E'
    Set srg = tCell.EntireRow.Columns("A:E")
    Set drg = dws.Range("B2")
    srg.Copy drg
    
    ' Copy 'F:BAA'
    Set srg = sws.Columns("F:BAA")
    Dim cCount As Long: cCount = srg.Columns.Count
    Set drg = dws.Range("A4:D4").Resize(cCount)
    With Application
        drg.Columns(1).Value = .Transpose(srg.Rows(3).Value)
        drg.Columns(2).Value = .Transpose(srg.Rows(1).Value)
        drg.Columns(3).Value = .Transpose(srg.Rows(2).Value)
        drg.Columns(4).Value = .Transpose(srg.Rows(tCell.Row).Value)
    End With
    
    ' Attempt to reference the empty cells in destination column 'D'.
    Set drg = Nothing ' reset
    On Error Resume Next ' prevent error if no empty cells
        Set drg = dws.Range("D4", dws.Cells(dws.Rows.Count, "D").End(xlUp)) _
            .SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    ' Delete entire rows of the empty cells.
    If Not drg Is Nothing Then ' there are empty cells
        drg.EntireRow.Delete
    'Else ' no empty cells; do nothing
    End If

End Sub