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

Question

这是我从这里开始的问题的延续： How to looping rows and then columns in Excel

当我整夜为这个问题努力时，我偶然发现了另一个障碍： 回顾一下：

我有一个如下所示的表 (B1:L7) 其中 A1 是查找值，B 行是标题，C 到 L 行是数据。

N 列是最终结果的可视化表示。为清楚起见，它以粗体突出显示。

注意：由于 N 列存在条件格式以供进一步分析，因此非常不鼓励选择整行并转置粘贴的解决方案。

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

1. 使用 A1 中的查找值循环 B 行以进行匹配 - DONE
2. 一旦宏找到与查找值匹配的值（即：B6 显示与 A1 匹配的值），前 10 个值（C 到 L）（即：第 6 行）的值将循环显示值 - 完成李>
3. 10 个值全部复制到 N 列（从 N1 开始并向下重复到 N10）（即：C6 值复制到 N1 ，D6 到 N2 等...）
4. 在遍历行时，选择范围并在单元格 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 个部分。

1. 找到匹配的行。
2. 复制该行中的值
3. 将复制的值粘贴到目标位置。