Excel粘贴到可见，转置为链接组合功能

Question

希望你们都做得很好。我正在编写一个工作簿，其中有一列包含 10 个连续单元格。

在另一张纸上有一行我想将该数据粘贴为转置但问题是，该行中的某些单元格不是连续的，其中一些是隐藏的。像图片中一样：

现在我只想将数据粘贴到可见单元格作为转置，并且这些单元格必须作为链接粘贴，就好像对第一张表所做的任何更改一样，第二张表中的相对单元格也应该更改。幸运的是，我自己做了很多工作，因为我发现如何仅通过遵循 VBA 代码粘贴到可见单元格：

Sub PasteToVisible()
'Declarations
Dim Range1            As Range
Dim Range2            As Range
Dim InputRange      As Range
Dim OutputRange     As Range

'Prompt Box Title
xTitleId = "Paste to Visible"
'Start Input Range
Set InputRange = Application.Selection
'Select input range box
Set InputRange = Application.InputBox("Copy Range :", xTitleId, InputRange.Address, Type:=8)
'Select output range box
Set OutputRange = Application.InputBox("Paste Range:", xTitleId, Type:=8)
'Loop to paste the range in visible cells
For Each Range1 In InputRange
    Range1.Copy
    For Each Range2 In OutputRange
        If Range2.EntireRow.RowHeight > 0 Then
            Range2.PasteSpecial
            Set OutputRange = Range2.Offset(1).Resize(OutputRange.Rows.Count)
            Exit For
        End If
    Next
Next
Application.CutCopyMode = False

结束子'

这可以将值粘贴到可见单元格，但只能在列中（不能转置）。对于转置和链接，我使用了一个简单的转置 excel 公式，如下图所示：

这可以链接转置形式的值。我想在一个步骤中组合所有三个功能（粘贴到可见、转置和作为链接）。请帮助我。我将非常感谢任何建议和帮助。提前致谢。

Answer 1

如评论中所述，这是我在评论中发布的示例。

Sub marine()

    'Key board shortcut Ctrl + Shift + C

    Dim cr As Range, dr As Range, c As Range
    Dim xTitleId As String
    Dim i As Integer

    xTitleId = "Paste to Visible"
    If TypeOf Selection Is Range Then Set cr = Selection

    On Error Resume Next
    Set dr = Application.InputBox("Destination Range: ", xTitleId, , , , , , 8)
    On Error GoTo 0

    If Not dr Is Nothing _
    And Not cr Is Nothing Then
        Set dr = dr.Resize(1, 1)
        i = 0
        For Each c In cr
            Do While dr.Offset(, i).EntireColumn.Hidden
                i = i + 1
            Loop
            dr.Offset(, i).Formula = "=" & c.Address(, , , True)
            i = i + 1
        Next
    End If

End Sub

我在 Ctrl+Shift+C 快捷方式中分配了它。
它将复制当前选择，然后提示您输入目标单元格。
只需选择目标单元格（单个单元格即可），它会粘贴链接。
尚未优化，但我希望这能给您一个想法。

Answer 2

您不能使用内置的 Excel pastespecial、transpose 和 link 单元格。

从here 改编一个想法，您可以创建一个命名范围，然后引用它。

命名范围称为myRange，您选择范围"A2:A6"，转到名称框，输入文本"myRange"，然后按回车键。然后您可以从Name Box 中选择myRange 以验证输入是否正确。或 Ctrl + F3 打开Name Manager。

函数是@BrettDJ，它从数字返回列字母。

请注意，您可以将其重构为更通用的函数，该函数接受输入范围和目标单元格并执行其他所有操作，然后从提示选择范围的按钮推送子程序中调用它。

 Option Explicit

Public Sub TransposeDataWithLink()

    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet2")
    Dim numColumns As Long
    numColumns = ws.Range("myRange").Rows.Count

    Dim startColumn As Long
    startColumn = 3 'this would be inputted in call
    Dim startRow As Long
    startRow = 2 ''this would be inputted in call

    Dim visibleColumns As Long
    Dim currCell As Range
    Dim myRangeStartCol As Long
    Dim myRangeStartRow As Long

    myRangeStartCol = ws.Range("myRange").Column
    myRangeStartRow = ws.Range("myRange").Row

    Dim columnLetter As String

    columnLetter = Col_Letter(myRangeStartCol)

    Do Until visibleColumns = numColumns

        Set currCell = ws.Cells(startRow, startColumn)

        If currCell.EntireColumn.Hidden = False Then

            visibleColumns = visibleColumns + 1

            Dim myRangeRef As String
            myRangeRef = "=" & columnLetter & CStr(myRangeStartRow + visibleColumns - 1)

            currCell.Formula = myRangeRef

        End If

        startColumn = startColumn + 1

    Loop

End Sub


Public Function Col_Letter(ByVal lngCol As Long) As String
    Dim vArr
    vArr = Split(ActiveSheet.Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

Answer 3

所以，就像 L42 一样。我找到了解决问题的方法。

Sub marine()

'Key board shortcut Ctrl + Shift + C

Dim cr As Range, dr As Range, c As Range
Dim xTitleId As String
Dim i As Integer

xTitleId = "Paste to Visible"
If TypeOf Selection Is Range Then Set cr = Selection

On Error Resume Next
Set dr = Application.InputBox("Destination Range: ", xTitleId, , , , , , 8)
On Error GoTo 0

If Not dr Is Nothing Then
    Set dr = dr.Resize(1, 1)
    i = 0
    For Each c In cr
        Do While dr.Offset(, i).EntireColumn.Hidden
            i = i + 1
        Loop
        dr.Offset(, i).Formula = "=" & c.Address(, , , True)
        i = i + 1
    Next
End If                                                                    
End Sub

这很好用。