Excel VBA - 從第一行復制值並粘貼到列中

Question

這是我從這里提出的問題的延續： How to looping rows and then columns in Excel

當我整晚都在解決這個問題時，我遇到了另一個障礙：回顧一下：

我有一個如下所示的表 (B1:L7) 其中 A1 是查找值，B 行是 header，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. 在遍歷行時，select 范圍和粘貼轉置單元格 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. 將復制的值粘貼到目的地。