Раскрасить строки

[amadeus017]

Сообщение от Aleksandr H.

Sub a()
    Dim str As String
    Dim cel As Range
    On Error Resume Next
    str = "ПлательщикИНН=" & Trim(CStr(InputBox("ИНН = ")))
    Set cel = Columns("A:A").Find(What:=str, After:=Range("A1"), LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).Range("A50000").End(xlUp).Row + 1, 1).Resize(36, 1).Value = _
        Range(cel.Offset(-7, 0), cel.Offset(28, 0)).Value
    Set cel = Nothing
End Sub

Спасибо за код, я его немного переделал (цифры поменял), но к сожалению, это не то что я думал.
Данный код работает так:
Открыв банковскую выписку при помощи Excel, запускаю макрос и выдает окно в которое нужно ввести ИНН (то что я не написал, но как раз и хотел, чтоб так было), и после ввода номера ИНН, макрос находит первый платеж от этой организации (их к сожалению бывает очень много но мелкие суммы), копирует эту секцию и вставляет в конец документа. Т.е., все другие остаются не удаленные, плюсом первую найденную оплату, дублирует еще раз(было 100 платежей, стало 101).

[Aleksandr H.]

Сообщение от Serge_Bliznykov

а что должна делать строчка:

Делать то что в ней прописано.
Ведь, как оказалось, не обязательно красить, можно скопировать на другой лист.

А поскольно запись не одна, то уж тут ТС надо поискать как обработать все результаты Find и покопировать на другой лист

[amadeus017]

Сообщение от Aleksandr H.

Делать то что в ней прописано.
Ведь, как оказалось, не обязательно красить, можно скопировать на другой лист.

А поскольно запись не одна, то уж тут ТС надо поискать как обработать все результаты и покопировать на другой лист

Что-то сложно для меня, я все таки бухгалтер, а не программист. Ну да попробую что-нибудь сделать, и на этом спасибо, что не оставили без внимания ))) !!!

[Aleksandr H.]

Сообщение от amadeus017

Что-то сложно для меня

тогда топорный вариант

Sub a()
    Dim str As String
    Dim cel As Range
    Dim firstAdress
    On Error Resume Next
    str = "ПлательщикИНН=" & Trim(CStr(InputBox("ИНН = ", , "7716004076")))
    Set cel = Columns("A:A").Find(What:=str, After:=Range("A1"), LookIn:=xlFormulas _
    , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    If Not cel Is Nothing Then
        firstAdress = cel.Address
        Do
            Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).Range("A50000").End(xlUp).Row + 2, 1).Resize(35, 1).Value = _
            Range(cel.Offset(-5, 0), cel.Offset(29, 0)).Value
            Set cel = Columns("A:A").FindNext(cel)
            If cel Is Nothing Then
                GoTo DoneFinding
            End If
        Loop While Not cel Is Nothing And cel.Address <> firstAdress
    End If
DoneFinding:
    Set cel = Nothing
End Sub

[amadeus017]

Сообщение от Aleksandr H.

тогда топорный вариант

Sub a()
    Dim str As String
    Dim cel As Range
    Dim firstAdress
    On Error Resume Next
    str = "ПлательщикИНН=" & Trim(CStr(InputBox("ИНН = ", , "7716004076")))
    Set cel = Columns("A:A").Find(What:=str, After:=Range("A1"), LookIn:=xlFormulas _
    , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    If Not cel Is Nothing Then
        firstAdress = cel.Address
        Do
            Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).Range("A50000").End(xlUp).Row + 2, 1).Resize(36, 1).Value = _
            Range(cel.Offset(-7, 0), cel.Offset(28, 0)).Value
            Set cel = Columns("A:A").FindNext(cel)
            If cel Is Nothing Then
                GoTo DoneFinding
            End If
        Loop While Not cel Is Nothing And cel.Address <> firstAdress
    End If
DoneFinding:
    Set cel = Nothing
End Sub

Этот вариант, лучше чем предыдущий (с кнопкой), но в нем "косяк". Теперь все платежи которые были в исходнике, находятся все и поочередно копируются друг под друга до "глубины" строк, а именно до A50000 (в моем случаи, получилась последняя строка "A50008").
По этому, я так думаю, что в исходнике найти все ИНН (посчитать сколько раз повторяется), затем запустить макрос и скопировать количество повторений на другой лист и убрать пробелы м/у скопированными платежами. Но это все же быстрее чем я делал (искал по ИНН, отмечал цветом, а потом отфильтровав все кроме отмеченного цветом, удалял, тем самым оставались платежи только по той организации, которая мне нужна бала)

[Aleksandr H.]

Сообщение от amadeus017

Теперь все платежи которые были в исходнике, находятся все и поочередно копируются друг под друга до "глубины" строк, а именно до A50000 (в моем случаи, получилась последняя строка "A50008").

Вошпєм так, на файлах из 8 сообщения у меня работает, полу/нерабочий код не выкладаю. Какая у вас структура не знаю, "косяка" дебажить не могу.

[amadeus017]

Сообщение от Aleksandr H.

Вошпєм так, на файлах из 8 сообщения у меня работает, полу/нерабочий код не выкладаю. Какая у вас структура не знаю, "косяка" дебажить не могу.

Это я видимо не так что-то делал. Я открывал выписку при помощи Excel, затем в него вставлял с форума код, в котором подправлял строки

Sheets(Sheets.Count).Cells(Sheets(S heets.Count).Range("A50000").End(xl Up).Row + 2, 1).Resize(36, 1).Value = _
Range(cel.Offset(-7, 0), cel.Offset(28, 0)).Value

и запускал. Так у меня на этом же листе, внизу один под одним, вставлялись платежки (сам виноват, не так делал).

Теперь все работает!!!
Огромное спасибо за экономию времени!!!

[Serge_Bliznykov]

Сообщение от amadeus017

Теперь все работает!!!

Отлично!

Посмотрите, может быть, Вам удобнее/быстрее будет воспользоваться отдельной программкой, которую я по быстрому набросал.

Copy_INN_EXE.rar

пароль на архив: 123
в архиве файл Copy_INN.exe

вот так выглядит интерфейс:
screenshot_copier.png

Ну, если программа пригодится - буду рад,
нет, значит, нет.

[amadeus017]

Сообщение от Serge_Bliznykov

Посмотрите, может быть, Вам удобнее/быстрее будет воспользоваться отдельной программкой, которую я по быстрому набросал.
Ну, если программа пригодится - буду рад,
нет, значит, нет.

Как говорится, то что доктор прописал!...
Т.е., это именно то, что я и хотел!!!
Большое спасибо!

[Serge_Bliznykov]

Большое пожалуйста!
Пользуйтесь на здоровье!