Vba Excel粘贴为可见，转换为链接合并功能

希望你们都做得很好。我正在制作一个工作簿，其中有一列连续的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

结束Sub'

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

---

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

您不能使用内置的Excel

pastespecial

、

transpose

和

链接

单元格

根据您的想法改编，可以创建一个命名范围，然后引用该范围

命名的范围称为

myRange

，您可以选择范围

“A2:A6”

，进入名称框，输入文本

“myRange”

，然后按enter键。然后，您可以从中选择

myRange

，以验证输入是否正确。或按Ctrl+F3组合键打开

函数的作用是从数字返回列字母

注意：您可以将其重构为一个更通用的函数，该函数接受输入范围和目标单元格，并执行其他所有操作，然后通过提示选择范围的按钮按钮按钮子命令调用该函数

 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

---

如评论中所述，下面是我在评论中发布的示例

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快捷方式中分配了它。
它将复制当前选择，然后提示您输入目标单元格。
只需选择目标单元格（单个单元格即可），它就会粘贴链接。

---

还没有优化，但我希望这能给你一个想法。

所以，到了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

---

这非常有效。

使用

Formula

或

formula1c1

属性并设置链接，而不是

PasteSpecial

。先生，您能举个例子吗？我试过了。我想我更喜欢你的！是的。。这很有效。非常感谢你。我真的很感谢你的帮助。非常感谢你。我尝试了你的函数，但其给出的错误“对象的方法范围”失败。我想我遗漏了一些东西。但无论如何，谢谢你，L42发布的解决方案在我需要的情况下工作得非常完美。我也感谢你的帮助。你可能需要更改Set ws=wb.Worksheets（“Sheet2”）你说得对，我错过了那张。非常感谢。