Перенос искомых данных на следующий лист

[Gusmanrus]

Доброго времени суток. Пытаюсь написать макрос для определения сколько израсходовал абонент. Максимум чего добился это копирования текста на другой лист в первые две строки. Нужно копировать на лист2 каждую последующую строку с шагом 2 или в каждую пустую. Помогите пожалуйста.Данные команды были найдены,сам шибко не знаю.

Sub Ìàêðîñ3()
'
' Ìàêðîñ3 Ìàêðîñ
'
Dim strStartAddr As String
Dim rgResult As Range
Dim sh As Worksheet
 
 For Each sh In Worksheets
      
      With sh.Cells
Cells.Find(What:="Ведомость начислений. Телефон ", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
 
 
strSelectTop = ActiveCell.Address
strSelectBottom = ActiveCell.Offset(0, 30).Address
Range(strSelectTop & ":" & strSelectBottom).Copy Destination:=Sheets("Лист2").[A1]
    
 strSelectTop = ActiveCell.Address
 Cells.Find(What:="Итог без НДС", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate


strSelectTop = ActiveCell.Address
strSelectBottom = ActiveCell.Offset(0, 38).Address
Range(strSelectTop & ":" & strSelectBottom).Copy Destination:=Sheets("Лист2").[A2] 




If Not Cells Is Nothing Then
strStartAddr = Cells.Address
End If

End With
Next sh
End Sub

___________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE] (это кнопочка с решёточкой #)
Не забывайте об этом!
Модератор.

[Gusmanrus]

Добрые люди помогите как можно скорей. И кстати с праздником вас всех.

[Hugo121]

Можно так, но тоже без переноса...
Да он думаю и не нужен
Из расчёта, что сумма от заголовка расположена всегда на 11 сток ниже, и ничего не пляшет по строке:

Sub tt()
    Dim a(), i&, ii&
    a = Sheets(1).UsedRange.Value
    ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If a(i, 23) = "Ведомость начислений. Телефон " Then
            ii = ii + 1
            b(ii, 1) = a(i, 53)
            b(ii, 2) = a(i + 11, 70)
            b(ii, 3) = a(i + 11, 78)
        End If
    Next
    Sheets(2).[a1].Resize(ii, 3) = b
End Sub

Или так, чуть с подстраховкой:

Sub tt()
    Dim a(), i&, ii&
    a = Sheets(1).UsedRange.Value
    ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If a(i, 23) = "Ведомость начислений. Телефон " Then
            ii = ii + 1
            b(ii, 1) = a(i, 53)
        End If
        If a(i, 8) = "Итого :" Then
            b(ii, 2) = a(i, 70)
            b(ii, 3) = a(i, 78)
        End If
    Next
    Sheets(2).[a1].Resize(ii, 3) = b
End Sub

P.S. Что за праздник, извините?

[Gusmanrus]

Огонь. Второй вариант подошел
Сегодня день программиста в России.

[Hugo121]

Оба на, а я и не знал...
Вероятно потому, что не программист. И не в России

[Gusmanrus]

Снова проблема. выскакивает ошибка:
run-time error '9'
subscript out of range
на строчке b(ii, 2) = a(i, 70).
помогите снова исправить,буду признателен.

Sub tt()
    Dim a(), i&, ii&
    a = Sheets(1).UsedRange.Value
    ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If a(i, 23) = "Ведомость начислений. Телефон " Then
            ii = ii + 1
            b(ii, 1) = a(i, 53)
        End If
        If a(i, 8) = "Итого :" Then
            b(ii, 2) = a(i, 70)
            b(ii, 3) = a(i, 78)
        End If
    Next
    Sheets(2).[a1].Resize(ii, 3) = b
End Sub

[Gusmanrus]

Новый исходник

[Hugo121]

Понятно. Форма поменялась. Никогда не случается это:

If a(i, 23) = "Ведомость начислений. Телефон " Then
            ii = ii + 1

Поэтому и ошибка на b(ii, 2)...

[Hugo121]

Вот код для нового файла (но не вникал...):

Sub tt()
    Dim a(), i&, ii&
    a = Sheets(1).UsedRange.Value
    ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If a(i, 24) = "Ведомость начислений. Телефон " Then
            ii = ii + 1
            b(ii, 1) = a(i, 54)
        End If
        If a(i, 8) = "Итого :" Then
            b(ii, 2) = a(i, 71)
            b(ii, 3) = a(i, 79)
        End If
    Next
    Sheets(2).[a1].Resize(ii, 3) = b
End Sub

[Gusmanrus]

Спасибо тебе огромное.выручил уже дважды