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

Question

这是我的第一篇文章。我一直在尝试自学 excel VBA，这非常具有挑战性。

无论如何，我一直在研究循环和范围等。

这是我的困境:

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”列，这是预期的，因为这是我编写的唯一代码。如何添加另一个循环来复制“新结果”下的所有内容并将其移动到新列。这样 J 将不断增加，最终我将得到按列分割的所有结果。

希望这是有道理的。

谢谢大家，

Answer 1

您不必循环遍历所有单元格。而是使用 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