Vba 循环遍历范围，一旦找到值，复制单元格值和下的所有内容，并移动到下一列

这是我的第一篇文章。我一直在努力自学excelvba，这是一个相当具有挑战性的过程

无论如何，我一直在循环和范围等工作

我的困境是：

Option Explicit

Sub Move_Data()

Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
Dim result As String

result = "New Results"

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 3 To LastRow
For j = 1 To LastColumn


If Cells(i, 1) = result Then
    j = j + 1
    Cells(i, 1).Copy Destination:=ActiveSheet.Cells(i, j)

End If


Next j
Next i

End Sub

我一点一点地把上面的内容组合起来。我的问题是：

我试图查看列“A”中的所有值。一旦找到“新结果”，我不仅要复制这个单元格，还要复制它下面的所有内容，复制到“J”列。然后在“B”列中找到字符串，并将范围复制到“K”列，以此类推

到目前为止，代码找到了“新结果”，并将其移动到“B”列，这是预期的，因为这是我编写的唯一代码。如何添加另一个循环，该循环将复制“New Results”下的所有内容，并将其移动到新列。这样，J将不断增加，最终我将得到按列分解的所有结果

希望这是有道理的

---

谢谢大家，

您不必遍历所有单元格。而是使用

Find（）方法

。我认为这样更有效率

Sub Move_Data()

    Dim rngFound As Range
    Dim intColLoop As Integer
    Dim LastColumn As Integer
    Dim result As String 'added in edit, forgot that, oops
    Dim intColPaste As Integer 'added in edit

    result = "New Results"
    LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    With Cells
        'in case the result is not on the ActiveSheet, exit code
        If .Find(result) Is Nothing Then Exit Sub

        '*****************Search all the columns, find result, copy ranges
        'search all the columns
        For intColLoop = 1 To LastColumn
            With Columns(intColLoop)
                'check if the result is in this column
                If Not .Find(result) Is Nothing Then
                    'find the result
                    Set rngFound = .Find(result)
                    'copy the found cell and continuous range beneath it to the destination column
                    Range(rngFound, rngFound.End(xlDown)).Copy Destination:=Cells(Rows.Count, 10 + intColPaste).End(xlUp)  'Edit : changed the "10" to "10 + intColPaste"
                    intColPaste = intColPaste + 1 'Edit : added counter for columns
                End If
            End With
        Next intColLoop 'proceed to next column
    End With
End Sub

---

你的第一篇文章写得很好，恭喜

Option Explicit
Sub Move_Data()

Dim SourceCol As integer
Dim DestCol As Integer
Dim LastRow As Long
'Dim LastColumn As Long
Dim rng As Range
Dim result As String
Dim Addr as string

  SourceCol = 1       'Column A
  DestCol = 2         'Column B
  result = "New Results"

  LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

  set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
          LookAt:=xlWhole, MatchCase:=False)
  While not rng is Nothing and Addr <> rng.Range.Address
  'If not rng is Nothing
    ActiveSheet.range(cells(rng.row, DestCol),cells(LastRow,DestCol) = _
            ActiveSheet.range(cells(rng.row,SourceCol), cells(LastRow,SourceCol))
  'End If
    Addr = rng.range.address(ReferenceStyle:=xlR1C1)
    set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
          LookAt:=xlWhole, MatchCase:=False)
  wend

End Sub

选项显式
子移动_数据（）
将SourceCol设置为整数
Dim DestCol作为整数
最后一排一样长
'最后一列一样长
变暗rng As范围
将结果变暗为字符串
Dim Addr作为字符串
SourceCol=1'列A
DestCol=2'列B
result=“新结果”
LastRow=ActiveSheet.Cells（Rows.Count，“A”）.End（xlUp）.Row
设置rng=ActiveSheet.Range（cells.Address）.Find（What:=Result，LookIn:=xlValues_
LookAt:=xlother，MatchCase:=False）
而not rng是Nothing，Addr rng.Range.Address
“如果不是，rng什么都不是
ActiveSheet.range（单元格（rng.row，DestCol），单元格（LastRow，DestCol）=_
ActiveSheet.range（单元格（rng.row，SourceCol），单元格（LastRow，SourceCol））
"完"
Addr=rng.range.address（引用样式：=xlR1C1）
设置rng=ActiveSheet.Range（cells.Address）.Find（What:=Result，LookIn:=xlValues_
LookAt:=xlother，MatchCase:=False）
温德
端接头

根据需要调整

SourceCol

和

DestCol

这是未经测试的，不在我的脑海中，因此可能需要稍作调整。使用

.Find（）

查找文本，然后将您的目标范围设置为刚刚找到的范围

---

如前所述，它将找到一个出现的

结果
。如果你有多个出现的
结果
，注释掉/删除
If…
和'End If`行，然后取消注释注释被注释的4行&它们将循环通过，找到所有行。
我有点发笑。：D难以置信，我们的答案是多么同步@BranislavKollár这很好，但是，代码找到了数据并将数据移动到了第J列。我如何分解它。例如：我希望新结果的第一个实例的所有内容都在第J列下。第二个实例和第K列下的所有内容。这有意义吗？我编辑了代码以满足您的需要。也可以这样做通过使用
…End（xlToLeft）
再次查找最后一列。请注意，粘贴的列将彼此相邻。第一个找到的范围将复制到列“J”，下一个找到的范围将复制到列“K”等。即使某些搜索列没有“结果”。谢谢。我在这一行得到了一个非可选的参数：rng.Range.address。在这种情况下，我假定您使用的是
While
循环。我已修复了这一行代码并进行了更新，以显示
While
循环。