循环范围，一旦找到值，则复制单元格值以及下面的所有内容并移动到下一列。

Question

循环范围，一旦找到值，则复制单元格值以及下面的所有内容并移动到下一列。

3

这是我的第一篇文章。我一直在尝试自学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”列中的所有值。一旦找到“New Results”，我不仅要复制此单元格，还要复制其下面的所有内容到“J”列。然后在“B”列中查找字符串并将范围复制到“K”列等。

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

希望这有意义。

谢谢大家。

- William G.

2个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- kolcinx · 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

- FreeMan · Answer 2

非常好的第一篇帖子，祝贺你！

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和DestCol。

这是未经测试的，只是我脑海中的想法，所以可能需要微调。使用.Find()查找您的文本，然后将目标范围设置为刚刚找到的内容。

按照现有的方式，它将找到一个result的出现。如果您有多个result的出现，请注释/删除If...和'End If`行，然后取消注释4行被注释掉的代码，它们将循环查找所有的结果。