Excel VBA PasteSpecial转置仅粘贴最后值的问题求助

嘿，我懂你的困扰啦——你当前的代码每次找到匹配项都会把内容粘贴到同一个单元格位置，自然会把之前的结果覆盖掉，最后就只剩最后一个匹配值了。咱们来调整下代码，让所有匹配值能依次排列在ThisCell的右侧，不会互相覆盖～

问题根源分析 #

你原来的代码里，每次执行ThisCell.Offset(0, 1).PasteSpecial时，都是指向同一个单元格（ThisCell右边第一个），所以新的匹配值会直接覆盖旧的。就算加了Resize(,20)，也只是把最后一次复制的单个值填充到整个20列的区域里，结果当然全是最后一个匹配值啦。

方案一：用计数器逐个赋值（简单直观） #

我们可以加一个计数器变量，记录当前已经放置了几个匹配值，每次找到新的匹配就把它放到右侧下一个单元格里，而且直接赋值比复制粘贴效率更高：

Dim i As Long, matchCount As Long
matchCount = 1 ' 从ThisCell右侧第一个单元格开始

For i = 4 To Finalrow
    ' 注意加上.Value明确取值，避免单元格格式干扰
    If Cells(i, 1).Value = ThisCell.Value Then
        ' 把匹配的B列值放到对应位置
        ThisCell.Offset(0, matchCount).Value = Cells(i, 2).Value
        matchCount = matchCount + 1 ' 计数器加1，下次放到下一个单元格
    End If
Next i

方案二：先收集所有匹配值再一次性粘贴（高效推荐） #

如果匹配数量较多，先把所有匹配值存到数组里，再一次性写入单元格区域，能减少对Excel单元格的操作次数，运行速度会快很多：

Dim i As Long, matches() As Variant, matchCount As Long
matchCount = 0

' 第一步：遍历收集所有匹配值到数组
For i = 4 To Finalrow
    If Cells(i, 1).Value = ThisCell.Value Then
        matchCount = matchCount + 1
        ' 动态调整数组大小，保留已有内容
        ReDim Preserve matches(1 To matchCount)
        matches(matchCount) = Cells(i, 2).Value
    End If
Next i

' 第二步：如果有匹配值，一次性写入右侧单元格
If matchCount > 0 Then
    ' Resize调整区域大小为1行matchCount列，刚好放下所有匹配值
    ThisCell.Offset(0, 1).Resize(1, matchCount).Value = matches
End If

额外小提示 #

• 尽量避免在循环里使用Copy/Paste，直接赋值Value的方式不仅更快，还不会影响剪贴板内容。
• 如果ThisCell是一个单元格对象，记得确保它已经被正确赋值（比如通过Set ThisCell = Range("某单元格")），避免运行时错误。

内容的提问来源于stack exchange，提问作者Michael1964