Excel VBA - 从第一行复制值并粘贴到列中

Question

这是我从这里开始的问题的延续:
How to looping rows and then columns in Excel
当我整夜解决这个问题时，我偶然发现了另一个障碍:
回顾一下:
我有一个如下所示的表 (B1:L7) 其中 A1 是查找值，B 行是标题，C 到 L 行是数据。
N 列是最终结果的可视化表示。为清楚起见，它以粗体突出显示。
注意:由于 N 列存在条件格式以供进一步分析，因此非常不鼓励选择整行和转置粘贴的解决方案。

这是我打算对下面的宏执行的操作:

使用 A1 中的查找值循环 B 行以进行匹配 - DONE

一旦宏找到与查找值匹配的值，(即:B6 显示与 A1 的匹配值)，前 10 个值(C 到 L)(即:第 6 行)的值将循环显示值 - 完成

所有 10 个值都复制到第 N 列(从 N1 开始并向下重复到 N10)(即:C6 值复制到 N1 ， D6 到 N2 等...)

在遍历行时，选择范围并粘贴转置单元格 N1

中的值选择

    Sub Looping_Click()
    'Search columns
    Dim c As Range
    'Search rows
    Dim r As Range
    'Range to copy and paste values
    Dim i As Range
    
    For Each r In Range(Range("B1"), Range("B1").End(xlDown))
        If r.Value = Range("A1").Value Then
            MsgBox "Found values at " & r.Address
            
            For Each c In Range(r.Offset(0, 1), r.Offset(0, 10))
                MsgBox "Values is " & c.Value
                ''''''''''''''''''''''''''''''''''''''
                MsgBox "Values is " & c.Value
                r.Selection.Copy
                Next i
                ''''''''''''''''''''''''''''''''''''''
                Range("N1").Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            Next c
        End If
    Next r
    End Sub

问题是当我运行宏时，没有值被粘贴在 N 列以及 RunTimeError 438 弹出
我用 '''' 突出显示了相关/可疑的麻烦宏部分

Answer 1

请尝试这种方法。

Sub Looping_Click()
    ' 167
    
    Dim Fnd         As Range        ' target to find
    Dim Arr         As Variant      ' values in found row
    Dim R           As Long         ' targeted row

    ' find the value of cell A1 in column B (=columns(2))
    Set Fnd = Columns(2).Find(Cells(1, "A").Value, , xlValues, xlWhole)
    If Fnd Is Nothing Then
        MsgBox "The requested value wans't found.", _
               vbInformation, "Unsuccessful search"
    Else
        ' define a range from the cell where the match was found,
        ' starting 1 cell to the right and then 10 cells wide, 1 row high
        ' read all found values from that range into an array
        Arr = Fnd.Offset(0, 1).Resize(1, 10).Value
        
        ' define a range from the cell N1, make it the same size as the array,
        ' then paste the array to the target range transposing the one column into one row.
        Cells(1, "N").Resize(UBound(Arr, 2), UBound(Arr)).Value = Application.Transpose(Arr)
    End If
End Sub

编辑:
引用您的评论，旁观者认为清晰，但一个论点是机器的零件越少，它就越不复杂，因此就越容易维护。上述程序有 3 个部分。

找到匹配的行。

复制该行中的值

将复制的值粘贴到目的地。