Макрос для удаления ненужных строк из буфера обмена

[СтаСС]

Макрос для удаления ненужных строк из буфера обмена
Искал в интернете и здесь на сайте но похожего не нашел. Возможно ли решение данной задачи с помощью макроса?
Копируются данные с сайта и нужно вставить их в ексель но не все а только 1-ю, 4-ю строку и все остальные строки начиная с той которая начинается с определенного слова... к примеру это слово "пиво" а копируемое выглядит так:

PHP код:

нужная строка 1
НЕнужная строка 2
НЕнужная строка 3
нужная строка 4
НЕнужная строка 5
               (тут разное количество строк и все они ненужны)
НЕнужная строка
пиво (нужная строка)
нужная строка
...(ну и все оставшиеся до конца копируемого строки нужны) 


вобщем чтоб получить вот так:

PHP код:

нужная строка 1
нужная строка 4
пиво (нужная строка)
нужная строка
...(ну и все оставшиеся до конца копируемого строки) 


p.s. сейчас я использую макрос в котором копировал без 1 и 4 строки.. но теперь понадобились они.. вот этот макрос

Sub VSTAVKA()
'
' VSTAVKA Макрос
'

'
    Application.ScreenUpdating = False
    Sheets("2").Select
    ActiveCell.FormulaR1C1 = ""
    Range("E1:E20").Select
    Selection.NumberFormat = "General"
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="Текст в кодировке Unicode", Link:=False, _
        DisplayAsIcon:=False
    Range("E1:E20").Select
    Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
    Sheets("2").Select
    Range("B1").Select
    Application.ScreenUpdating = True
End Sub

[AlexM12]

Пробуйте так

Sub VSTAVKA()
    Dim Arr, MyArr()
    Dim i As Long, n As Long, iStr As String, Bln As Boolean
    iSrt = "пиво"
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Arr = Split(.GetText, Chr(10))
    End With
    For i = 0 To UBound(Arr)
        If InStr(Arr(i), iSrt) = 1 Then Bln = True
        If i = 0 Or i = 3 Or Bln = True Then
            ReDim Preserve MyArr(0 To n)
            MyArr(n) = Arr(i): n = n + 1
        End If
    Next i
    Range("A1").Resize(n, 1) = Application.Transpose(MyArr)
End Sub

Если надо в одну ячейку, то поменять последнюю строку на

Range("A1") = Join(MyArr, Chr(10))

[СтаСС]

AlexM12, да СПАСИБО!!! - выбирает то что надо СУПЕР!
Но есть одно но.. формат вставки не такой как в моем макросе (я писал его через макрорекордер) .. теперь получается что в каждой строке заполнена только одна ячейка.. а в моем было вставка в формате "Текст в кодировке Unicode" и у меня заполнялась таблица плюс в (Е1:Е20) еще и с разделителем ( : ) правда что б "заработали" разделители я прогонял макрос два раза иначе почему-то не хочет разделять.. после первого раза выскакивает окно:" Здесь уже есть данные. Вы хотите заменить их? " я нажимал "ок" и второй раз запускал макрос.. тогда все получалось как надо..
Я сейчас пробовал свой макрос вставить в ваш и наоборот.. но естественно у меня это не получилось ((
Можно их как-то корректно объединить? Пжлст )) Правда боюсь что если его надо будет прогонять два раза из-за разделителя то ничего не выйдет.. ведь удалять будет опять строки.. (( Может чтоб "автоматом"
второй раз прогонялась лишь вставка именно в Е1:Е20 (верней из-за 1 и 4 строки теперь это будет Е3-Е22) ???
И еще.. я ваш макрос так и не понял.. вот например мне понадобится кроме 1 и 4 строки еще и 2-ю к примеру или 8-ю.. как и что там тогда поменять надо? "Разжуйте" пожалуйста немного! СПАСИБО!!! Сорри за наглость))

[СтаСС]

наверно с примером будет легче понять..

[СтаСС]

Решил старую проблему "запуска второго раза макроса".. оказывается достаточно при первом запуске книги перед запуском основного макроса "вставки" запустить типа такой ерунды на новом-пустом листе

Sub Макрос2()
'
' Макрос2 Макрос
'

'
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "0:00"
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
    Range("A1:C1").Select
    Selection.ClearContents
    Range("A1").Select
End Sub

дальше все идет как надо без повторного прогона макроса... и как я раньше до этого не додумался....................... (уже засунул такой макрос в свою книгу и назвал auto_open и вуаля ))))
осталась одна проблема.. как вставить в предложенный AlexM12 макрос код что б вставка была в формате Текст в кодировке Unicode у меня не выходит почемуто ))


ночи мне на все хватило )) эту задачу тоже решил правда способ "топорный" но действенный ))

Sub Макрос3()

    Application.Run "макрос AlexM12"
    Range("A1:A23").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
End Sub

у меня остался только вопрос который я писал выше

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

я ваш макрос так и не понял.. вот например мне понадобится кроме 1 и 4 строки еще и 2-ю к примеру или 8-ю.. как и что там тогда поменять надо? "Разжуйте" пожалуйста немного! СПАСИБО!!! Сорри за наглость))

и еще новый созрел.. как из буфера удалить строки которые начинаются с символа "(" ? Вот AlexM12 написал макрос и что в него дописать еще чтоб после слова "пиво" копируются все строки кроме тех что начинаются с открытых скобок тоесть с символа "(" ? Заранее спасибо!!! ))

[AlexM12]

К сожалению ваш файл не дал нужной информации и ссылка в файле на платный контент. Нет желание туда заходить.
Поясню как работает макрос.
Строки из буфера обмена помещаются в массив Arr. В каждом элементе массива оказывается одна строка. Разделение строк по символу с кодом 10 - перевод строки.
Элементы массива имеют номера от 0 и далее.
Первая строка - 0, 4 строка - 3
Строка, которая начинается со слова из переменной iStr должны сохранится.
В первом IF ищем строку, начинающуюся со слова из iStr и когда находим, меняем значение логической переменной Bln на True.
Логическое выражение второго IF становится TRUE, когда выполняется одно из трех условий. Т.е. при первой строке (0) или при четвертой (3) или Bln = True
Когда условие выполняется, то строки пишем в массив MyArr
В последней строке массив записываем в столбец А.

У вас в коде происходит деление строк по столбцам с разделителями Tab и двоеточие.
Так как ваши примеры бесполезны, сделайте образец того что надо вставить в таблицу. Для этого скопируйте нужный фрагмент страницы сайта и сохраните в txt или doc файл. Пока не знаю что будет лучше копировать в буфер.
Жду файл.

[СтаСС]

Я извиняюсь но данный мной контент АБСОЛЮТНО бесплатен.. и весь сайт и тем более ссылка что я кинул..может это из-за UA ? Но не важно вобщем..
Как я уже написал выше проблема вставки более-менее решена.. как работает ваш макрос буду разбираться по вашему пояснению, вам отдельное за это спасибо!
Помогите если это возможно усовершенствовать ваш макрос - чтоб после кодового слова "пиво" копировались все строки кроме тех что начинаются с открытых скобок ( символ "(" )
Добавляю архив где все более понятно написано и показано на картинке.. спасибо

[Aleksandr H.]

Может поможет слегка
http://excelvba.ru/programmes/Parser/samples/MyScore

[СтаСС]

Спасибо! Правда не особо помогло) Такой парсер у меня есть для проги скаченной с инета... а тут я свою как бы написал для личного пользования и пока обхожусь ручной вставкой.. еще не разбаготел на заказ парсера для нее ))
Зато нашел там ссылку на тот же сайт что и в примере у меня но с RU (http://www.myscore.ru) попробовал зайти - не получается.. про плату ничего.. а просто кидает на UA

P.S. Ссылку сохранил может действительно прийду к этому решению..

[AlexM12]

Так кажется получилось

Sub VSTAVKA()
    Dim Arr, Arr_st, MyArr()
    Dim i As Long, j As Long, n As Long, iStr As String, Bln As Boolean
    iSrt = "Последние"
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Arr = Split(.GetText, Chr(10))
    End With
    For i = 0 To UBound(Arr)
        If InStr(Arr(i), "(") = 0 Then
            If InStr(Arr(i), iSrt) = 1 Then Bln = True
            If i = 0 Or i = 3 Or Bln = True Then
                ReDim Preserve MyArr(0 To 5, 0 To n)
                Arr_st = Split(Arr(i), Chr(9))
                For j = 0 To UBound(Arr_st)
                    If j < 4 Then
                        MyArr(j, n) = Arr_st(j)
                    Else
                        MyArr(j, n) = 1 * Split(Arr_st(j), Chr(58))(0)
                        MyArr(j + 1, n) = 1 * Split(Arr_st(j), Chr(58))(1)
                        Exit For
                    End If
                Next j
                n = n + 1
            End If
        End If
    Next i
    Range("A1").Resize(n, 6) = Application.Transpose(MyArr) 
End Sub

Проверял на тексте из файла 001.txt В буфер брал то что после звездочек.