помогите с простым алгоримтом

[Tirendus]

Нужно что б макрос прошелся по столбцу и скопировал все ячейки, начиная от той, которая содержит "*Total Games*", заканчивая той, которая содержит "*total payment*". Таких диапазонов несколько. Пробую сделать через цикл, ничего не получается. Пробовал через поиск, но так и не разобрался как с ним правильно работать. Пожалуйста подскажите как правильно скопировать несколько таких диапазонов на новый лист в один столбец.

З.Ы. не ругайетсь на код, я совсем новичек )

Sub test()
Dim i As Integer
    For i = 1 To 1000
        Do
            If Cells(i, 4).Value Like "*Total Games*" Then
                Cells(i, 4).Copy
                Worksheets("Sheet 2").Range("a65000").End(xlUp).Paste
                i = i + 1
            End If
        Loop Until Cells(i, 4).Value Like "*total payment*"
    Next
 End Sub

доу, даже в названии темы ошибся

[EducatedFool]

Ну и... где файл с примером?
Вставлять диапазоны на лист Sheet 2? Или на вновь создаваемый лист?
Копировать вместе с заголовками диапазонов (Total Games, total payment), или нет?
Что делать, если после Total Games нет total payment?

[Tirendus]

Привет, не знаю зачем тут пример, думаю и без него всё понятно.

Вставлять диапазоны на лист Sheet 2? Или на вновь создаваемый лист?

это не важно, мне главное увидеть как оно делается... лучше на новый лист, я просто не понимаю как вставлять больше одного раза... т.е. продолжать вставлять в тот же столбец, при этом не заменяя то, что вставили перед этим.

Копировать вместе с заголовками диапазонов (Total Games, total payment), или нет?

без заголовков

Что делать, если после Total Games нет total payment?

Это отчет, после Total Games всегда будет total payment.

хотя в принципе, если нужен файл, то вот он...

на этом листе между Total Games и total payment есть определенное количество игр, напротив них стоят количества закачек... например

Scott Dixon Racing............................. ........1

вот эту инфу в идеале нужно вставить в новый лист в столбцы А и Б соответственно.

[Tirendus]

решено, хоть и криво)

Sub test()
Dim i As Long
Dim j As Long
Dim k As Long
i = 1
j = 1
k = 1
Do Until i = 65000
Do Until (Worksheets(1).Cells(i, 4) Like "*Total Games*") Or (i >= 65000)
i = i + 1
Loop
j = i
Do Until (Worksheets(1).Cells(i, 4) Like "*Total Payment*") Or (i >= 65000)
i = i + 1
Loop
Worksheets(1).Cells(j, 4).Resize(i - j + 1, 1).Copy
Worksheets(1).Paste Destination:=Worksheets(2).Cells(k, 1)
Worksheets(1).Cells(j, 7).Resize(i - j + 1, 1).Copy
Worksheets(1).Paste Destination:=Worksheets(2).Cells(k, 2)
k = k + 1 + i - j
Loop
End Sub

[EducatedFool]

Вот вариант побыстрее:

Option Compare Text
Const str1 = "Total Games", str2 = "Total Payment"

Sub test()
    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = Worksheets(1)
    Dim sh2 As Worksheet: Set sh2 = Worksheets(2)
    sh2.Cells.Clear ' очищаем итоговый лист
    Dim ra As Range, MyRange As Range, NewRange As Range

    Dim x As Range, y As Range: Set ra = sh.[d:d]    ' диапазон для поиска
    Set x = ra.Find(str1, ra.Cells(1), , xlPart)    ' ищем первое вхождение
    If Not x Is Nothing Then
        firstAddress = x.Address    ' запоминаем адрес первой найденной ячейки
        Do
            Set y = ra.Find(str2, x, , xlPart)
            ' Debug.Print x.Row, y.Row, firstAddress
            If y.Row - x.Row > 1 Then
                Set MyRange = sh.Range(x.Offset(1), y.Offset(-1))
                Set NewRange = sh2.Range("a" & sh2.Rows.Count).End(xlUp) _
                               .Offset(1).Resize(MyRange.Rows.Count)
                MyRange.Copy NewRange
                NewRange.Offset(, 2).Interior.ColorIndex = Fix(Rnd(NewRange.Row) * 50) + 5
                NewRange.Offset(, 2).Cells.Merge
                NewRange.Offset(, 2) = "Сюда скопирован диапазон" & vbLf & MyRange.Address
            End If
            Set x = ra.Find(str1, x, , xlPart)    ' ищем следующий диапазон
        Loop While Not x Is Nothing And x.Address <> firstAddress
    End If
    sh2.UsedRange.EntireColumn.AutoFit: sh2.Columns(3).ColumnWidth = 22
End Sub

Это не самый лучший алгоритм в твоём случае.
К примеру, в 30-й строке между словами Total Games в исходном варианте файла находилось 2 пробела.
Макрос в этом случае придётся переделывать...

[Tirendus]

Игорь, спасибо, за комментарии - отдельное.

К примеру, в 30-й строке между словами Total Games в исходном варианте файла находилось 2 пробела

пофиг, документы не слишком большие и на следующем листе все эти пробелы удаляются

[Aent]

Tirendus, вот вам ещё вариант кода, делающего то же самое что и ваш, но использующего поиск.

Public Sub RowCopier()
    Const iCol As Long = 4    'Номер столбца в котором ведём поиск
    Dim iMax As Long
    Dim r As Range, r1 As Range, r2 As Range, lc As Range
    Dim dr As Range
    Set dr = Worksheets(2).Cells(1) 'принимающий ранг
    Application.ScreenUpdating = False
    With Worksheets(1)
        iMax = .Cells.Rows.Count
        If .Cells(iMax, iCol) = vbNullString Then
            iMax = .Cells(iMax, iCol).End(xlUp).Row    'Номер последней заполненной строки в столбце iCol
            If iMax = 1 Then Exit Sub
        End If
        Set r = .Cells(1, iCol).Resize(iMax, 1)    'ранг в котором ведём поиск
        Set lc = .Cells(iMax, iCol)    'последняя ячейка ранга
        Do
            Set r1 = r.Find("Total Games", after:=lc, lookAt:=xlPart)
            If r1 Is Nothing Then Exit Sub 'не нашли стартовую строку символов
            Set r2 = .Range(r1.Offset(1, 0), lc).Find("Total Payment", after:=lc, lookAt:=xlPart)
            If r2 Is Nothing Then Exit Sub 'не нашли финальную строку символов
            .Range(r1, r2).Copy dr
            .Range(r1.Offset(0, 3), r2.Offset(0, 3)).Copy dr.Offset(0, 1)
            If r2.Row = iMax Then Exit Sub 'необязательный выход для последней строки ранга
            'этот выход введён для обработки ситуации когда вычисление r2.Offset(1, 0)
            'вызовет ошибку т.е когда iMax = .Cells.Rows.Count
            Set dr = dr.Offset(r2.Row - r1.Row + 1, 0) 'сдвигаем принимающий ранг
            Set r = .Range(r2.Offset(1, 0), lc)         'корректируем область поиска
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

[Tirendus]

спасибо Увы, как оказалось, мой пдф конвертер начал выдавать информацию в полнейшей абрекадабре и макрос просто ушел коту под хвост а я думал, можно будет его применять ко всем документам... в общем, шит хэпнс)