Всем привет!

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

Код: (vb)

'find last not empty cell in "B"
    kLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
'Up from last not empty cell to row 2
    For k = kLastRow To 2 Step -1
        
 'if cells in B have "*+*" - add 1 rows
        If Cells(k, "B") Like "*+*" Then
            Rows(k).Select
            Selection.Copy
            Rows(k).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        
'if cells in B have "*+*+*" - 2 rows
        If Cells(k, "B") Like "*+*+*" Then
            Rows(k).Select
            Selection.Copy
            Rows(k + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        
'if cells in B have "*+*+*+*" - 3 rows
        If Cells(k, "B") Like "*+*+*+*" Then
            Rows(k).Select
            Selection.Copy
            Rows(k + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If

    Next k

' Delete "+..+" in Column "B"

     Dim n1 As Long, n2 As Long

'find last not empty cell in "B"
    jLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
'Up from last not empty cell to row 2
    For j = jLastRow To 2 Step -1
        
        n1 = InStr(1, Cells(j, "B"), "+")
        n2 = InStr(n1 + 1, Cells(j, "B"), "+")
        n3 = InStr(n1 + 2, Cells(j, "B"), "+")

'if cells in Column "B" have "*+*+*+*" - put values between "+" in each rows and delete "+"

        If Cells(j, "B") Like "*+*+*+*" Then
                Cells(j, "B") = Right(Cells(j, "B"), n1 - 1)
                Cells(j - 1, "B") = Mid(Cells(j - 1, "B"), n2 + 1, n3 - n1 - 1)
                Cells(j - 2, "B") = Mid(Cells(j - 2, "B"), n1 + 1, n2 - n1 - 1)
                Cells(j - 3, "B") = Left(Cells(j - 3, "B"), n1 - 1)
        End If

'if cells in Column "B" have "*+*+*" - put values between "+" in each rows and delete "+"

        If Cells(j, "B") Like "*+*+*" Then
                Cells(j, "B") = Right(Cells(j, "B"), n1 - 1)
                Cells(j - 1, "B") = Mid(Cells(j - 1, "B"), n1 + 1, n2 - n1 - 1)
                Cells(j - 2, "B") = Left(Cells(j - 2, "B"), n1 - 1)
        End If

'if cells in Column "B" have "*+*" - put values between "+" in each rows and delete "+"

        If Cells(j, "B") Like "*+*" Then
                Cells(j, "B") = Right(Cells(j, "B"), n1 - 1)
                Cells(j - 1, "B") = Left(Cells(j - 1, "B"), n1 - 1)
        
        End If

    Next j

Доброго времени суток и всех с новым годом!

Прошу помощи специалистов в решении вопроса.

Есть таблица вида:

A	B	C	D	E
100	01	word1	word2	word3
101	01+02	word4	word5	word6
102	01+02+03	word7	word8	word9

Есть 2 условия.
1. Нужно полностью "повторить" (продублировать) строчки, где в ячейках столбца "B" содержится знак "+". Причем количество повторений строки = количеству знаков "+" в столбце "B".
2. При этом, в каждой продублированной строчке, в столбце "B" должно остаться только одно не повторяющееся значение (без "+").

A	B	C	D	E
100	01	word1	word2	word3
101	01	word4	word5	word6
101	02	word4	word5	word6
102	01	word7	word8	word9
102	02	word7	word8	word9
102	03	word7	word8	word9

Количество "+" в столбце "B", обычно, не превышает 3-х, но бывает и 4.


Нехитрый код неспециалиста-любителя сейчас выглядит вот так:

Код: (vb)

Sub ppp()
    Dim kLastRow As Long
    Dim k As Long

    kLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    'Up from last not empty cell to row 2
    For k = kLastRow To 2 Step -1

        If Cells(k, "B") Like "*+*" Then
            Rows(k).Select
            Selection.Copy
            Rows(k).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If

        If Cells(k, "B") Like "*+*+*" Then
            Rows(k).Select
            Selection.Copy
            Rows(k + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
    Next k

    Columns("B:B").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="=""+""", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Здесь с самого низа столбца "B" ищется знак "+", строки копируются по количеству "+" и.... практически всё. Еще подкрашиваются повторяющиеся значения, где в столбце "B" имеется "+" - для ручной доработки.
"Код" выполняется долго, и не удаляются "повторяющиеся" значения.

Помогите пожалуйста допилить обработку.

Заранее БЛАГОДАРЮ!

Здравствуйте!

Подскажите, пожалуйста, уважаемые специалисты, почему при выполнении веб-запроса (получение внешних данных - из интернета) с некоторых страниц сбивается кодировка и результат превращается вот в такие "кракозябры": Название статьи   Ð¡Ñ‚раницы
Можно ли каким-то образом обработать весь полученный в таком вот виде результат в нормальный вид?

Запрос выполняется нехитрым способом по скрипту вот из этой темы.
Кодировщик говорит что исходная кодировка UTF-8, но как из нее сделать нормальную (вероятно, win1251) - мне не понятно.

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

Благодарю за любую помощь!

Извините, возможно я просто ошибся темой; очень хотелось найти решение.

Если кому-то будет интересно, вот рабочий вариант:

Код: (vb)

Sub EX()
        Dim vRetVal
        On Error Resume Next
        vRetVal = InputBox("Введите ссылку:", "Получение ссылки")
        If vRetVal = "" Then Exit Sub

        With ActiveSheet.QueryTables.Add(Connection:= _
            "URL;" & vRetVal, Destination:=Range("A1"))
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = """restab"""
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
End Sub

Спасибо за помощь

По отдельности - да: формочка - появляется сама по себе, запрос - отрабатывает сам по себе.
А вместе - нет, потому и спрашиваю любого дельного совета.

Здравствуйте!

Есть вопрос на который никак не могу найти полноценный ответ.

У меня есть "веб-запрос" который выдает на лист данные из вшитой в него ссылки:

Код: (vb)

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://www.примерсайта.ru/contents.asp?titleid=123456", Destination:=Range("A1"))
        .Name = "Res"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = """restab"""
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

(вставил именно в таком виде, потому что в случае использования "режима кода" - данные дублируются)

Необходимо сделать так, чтобы ссылку для этого запроса давал сам пользователь (из формы).
И после успешного получения ссылки - отрабатывается запрос.
И, казалось бы, самый простой способ - запросить ее из формы типа MSGBOX в параметр, например вот так:

Код: (vb)

    On Error Resume Next
    Set vRetVal = Application.InputBox("Введите ссылку:", "Получение ссылки")
    If vRetVal Is Nothing Then
        MsgBox "Отмена", vbCritical, "Нет данных"
    End If

А потом вставить этот параметр в запрос:

Код: (vb)

        "URL;vRetVal", Destination:=Range( _
        "A1"))

Однако, в таком виде решение не работает; вероятно, в MSGBOX не заложен необходимый функционал.
Пока найти подходящее решение не получается.

Буду рад любой помощи.
Заранее благодарю!

Дмитрий, спасибо за помощь!
Разобрался, внес изменения к себе, работает.

Товарищи специалисты, помогите, пожалуйста, дорешать задачку.
Пока получилось вот так:

Код: (vb)

Sub Procedure_1()
 
    Dim lLastRow As Long
    Dim i As Long
    
    'Определение последней заполненной ячейки в столбце С.
    lLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
    'Двигаемся от последней заполненной строки вверх.
    For i = lLastRow To 4 Step -1
        If Cells(i, "B") = "" Then
                Rows(i).Delete
        End If

        If Cells(i, "B") <> "" And Cells(i - 1, "B") <> "" Then
                Rows(i).Insert
                Cells(i, "A") = "без автора"
                Cells(i, "A").Font.Color = RGB(255, 0, 0)
        End If
    Next i
 
End Sub

Но есть пара моментов:
- если в "For..." меняется 4 на 3 или 2, то "без автора" также подставляется выше первой статьи, а это не нужно;
- "без автора" не ставится после последней строчки с названием статьи и без автора.

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

Файл "пример" с таблицами (можно добавить вместо таблиц в первом сообщении).

Здравствуйте, уважаемые специалисты!
Всем-всем-всем добра и хорошего настроения!

Хочу Вас побеспокоить еще одной задачкой, поскольку не могу найти полноценного решения своего вопроса, а половинчатые - не подходят.

Имеется таблица в диапазоне "A1:B400" такого вида (Статьи - "A", Страницы - "B"):

Статьи                  Страницы Название статьи   1 Название статьи   2 Фамилия И.О.    Название статьи   3 Фамилия И.О.    Название статьи   4 Фамилия И.О.        Название статьи   5 Фамилия И.О.    Название статьи   6 Название статьи   7 Название статьи   8 ...

и мне нужно сделать из нее вот такой вариант:

Статьи                  Страницы Название статьи   1 без автора Название статьи   2 Фамилия И.О.    Название статьи   3 Фамилия И.О.    Название статьи   4 Фамилия И.О.    Название статьи   5 Фамилия И.О.    Название статьи   6 без автора Название статьи   7 без автора Название статьи   8 без автора ...

Т.е. нужно сделать так, чтобы выполнились одновременно условия:
1. Удалить полностью пустые строчки после строчек с фамилией;
2. Добавить строчки в случае, если после названия статьи НЕТ фамилии, внести (в строчку столбика А) "без автора" и подсветить красным. В этом случае, думаю, лучше ориентироваться на столбик "B", т.к. добавить строчку и внести "без автора" нужно только тогда, когда страницы в B идут подряд.

Уточню, что в диапазоне "A1:B400" после последней заполненной строчки могут быть пустые строки; последняя заполненная, например, может быть 389.

Заранее благодарю за беспокойство.

Большое спасибо!

Здорово, работает, СПАСИБО!
Это отличное решение - ставить "+1" после каждого шага, это корректно показывает общий процесс выполнения.

Только пара моментов:
У меня эксель 2016 и прогресс-бар - почему-то закрашен темно-зеленым цветом, и прогресса из-за этого почти и не видно. Это можно как-то поменять, чтобы был обычный цвет?
И если Вас не затруднит, скажите пожалуйста, а как это же самое применить к форме "UserForm" (из примера) для заливки серой полосы синим цветом?

Доброго времени суток, добрый люди!
Всем хорошего настроения, здоровья и благополучия!

Хотел просить помощи относительно понимания работы статус/прогресс-бара.
Смотрел тему как работает статус-бар.
Искал по форуму и нашел, что прогресс-бар можно применить к циклам, но у меня в скрипте циклов почти нет; может быть есть в отдельном "кусочке", но он влияет только на небольшую часть документа.

В итоге, использовал форму UserForm из файла примера (Tips_ShowProgressBar.xls) и все, что добился - появление формы с 0% в начале работы скрипта и резкий переход в 100% по окончанию его работы.
Мой скрипт - это т.н. "сборник" кусочков, где есть как записанные макрорекордером простые обработки (скопировать это отсюда туда, применить к скопированному шрифт и т.д.), так и сложные обработки, собранные с просторов интернета, в т.ч. и с данного форума (одна из них). Каждый кусочек "выделен в блок" (имеет закомментированное примечание), и хотелось бы так и оставить, поскольку работает как надо.

Вот, например, кусочек:

Код: (vb)

' Очистка
    Sheets("2_handler").Select
    Columns("E:F").Select
    Selection.Delete Shift:=xlToLeft
    Range("Таблица1[[Статьи и ниже ФИО]:[Номера]]").Select
    Selection.ClearContents
    Sheets("1-import").Select
    Columns("A:F").Select
    Selection.Delete Shift:=xlToLeft

'   Удалить все листы с результатами кроме "L1" and "L2"
Dim i As Long
Application.DisplayAlerts = False
   For i = Sheets.Count To 1 Step -1
       If Sheets(i).Name <> "L1" Then
           If Sheets(i).Name <> "L2" Then
                Sheets(i).Delete
           End If
       End If
   Next
Application.DisplayAlerts = True

'Путь до файла запроса .iqy
    IQYFile = "D:\link.iqy"
    With ActiveSheet.QueryTables.Add(Connection:= _
       "FINDER;" & IQYFile, Destination:=Range("A1"))
        .BackgroundQuery = True
        .TablesOnlyFromHTML = True
        .Refresh BackgroundQuery:=False
        .SaveData = True
    End With

И вот хотелось бы, чтобы после каждого такого "кусочка" в форме выполнения скрипта отображался ход в процентах.
Или не в форме, а, например, в нижней части листа - "квадраты и проценты" (из листа примера Tips_ShowProgressBar.xls).
Ну или было хоть какое-то оповещение о ходе выполнения кроме банальных

Код: (vb)

Application.StatusBar = "Ждите, обрабатываю запрос..."

в начале и

Код: (vb)

MsgBox "Готово"

в конце.

Буду рад любой подсказке/помощи/доброму совету.

Супер! Спасибооо!

Действительно, это моя "недоработка"; Ваш скрипт корректно работает в "диапазоне заполненных ячеек".
С одной стороны, в моем случае 1000 - это сильно через край; в среднем количество обрабатываемых ячеек за 1 цикл, варьируется от 150 до 550. Т.е. с 1 строки (K2) и до последней заполненной (K540, например) - слеш / присутствует; а дальше начинаются пустые ячейки.
С другой стороны, чтобы постоянно не править руками этот параметр, имеет смысл оставить ну, хотя бы, 600; в ряде случаев этого будет достаточно. Ну а 1000 - это уж точно "наверняка".