Диапазон прохождения цикла, как только значение найдено, скопируйте значение ячейки и все ниже и перейдите к следующей колонке

Question

Это мой первый пост. Я пытался научить себя превосходить 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 

Понемногу я поставил выше вместе. Вот мой вопрос:

Я пытаюсь посмотреть все значения в столбце «А». Как только «Новые результаты» найдены, я хочу скопировать не только эту ячейку, но все под ней, в столбец «J». Затем найдите строку в столбце «B» и скопируйте диапазон в столбец «K» и т. Д.

До сих пор код находил «Новые результаты» и перемещает его в столбец «B», который ожидается, поскольку это единственный код Я написал. Как добавить еще один цикл, который будет скопировать все в разделе «Новые результаты» вместе с ним и переместить его в новый столбец. Таким образом, J будет продолжать расти, и в итоге у меня будут все результаты, разбитые на столбцы.

Надеюсь, это имеет смысл.

Спасибо,

Answer 1

Вам не нужно проходить через все ячейки. Скорее используйте Find() method. Думаю, это более эффективно.

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 

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 

Adjust SourceCol и DestCol по мере необходимости.

Это непроверено и у меня на голове, поэтому может потребоваться незначительная настройка. Используйте .Find(), чтобы найти свой текст, а затем укажите диапазон назначения = то, что вы только что нашли.

Как написано, он найдет одно из них: result. Если у вас есть несколько вхождений result, закомментируйте/удалите строки If... и «End If», а затем раскомментируйте 4 строки, которые прокомментированы. & они пройдут, найдя их все.