Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
21.06.2021, 03:57:10

Войти
Название темы должно отражать её содержание.
Темы типа "ПОМОГИТЕ!!!", "Срочно!", "Не получается сделать", "Нужна помощь" и т.п. будут удаляться без объяснения причин
32 305 Сообщений в 5 230 Тем от 13 424 Пользователей
Последний пользователь: asgvba
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
  Просмотр сообщений
Страниц: [1] 2
1  Основные форумы / Вопросы по Excel и VBA / Re:Дублирование строк по условию в ячейке конкретного столбца : 07.01.2021, 16:47:34
Всем привет!

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

Код: (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
2  Основные форумы / Вопросы по Excel и VBA / Дублирование строк по условию в ячейке конкретного столбца : 04.01.2021, 03:47:14
Доброго времени суток и всех с новым годом!

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

Есть таблица вида:
ABCDE
10001word1word2word3
10101+02word4word5word6
10201+02+03word7word8word9

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

Количество "+" в столбце "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" имеется "+" - для ручной доработки.
"Код" выполняется долго, и не удаляются "повторяющиеся" значения.

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

Заранее БЛАГОДАРЮ!
3  Основные форумы / Вопросы по Excel и VBA / Сбивается кодировка при выполнении веб-запроса : 28.11.2020, 22:43:18
Здравствуйте!

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

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

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

Благодарю за любую помощь!
4  Основные форумы / Вопросы по Excel и VBA / Re:Получение интернет-ссылки от пользователя через форму : 26.11.2020, 19:56:28
Извините, возможно я просто ошибся темой; очень хотелось найти решение.

Если кому-то будет интересно, вот рабочий вариант:
Код: (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


Спасибо за помощь
5  Основные форумы / Вопросы по Excel и VBA / Re:Получение интернет-ссылки от пользователя через форму : 26.11.2020, 18:57:58
По отдельности - да: формочка - появляется сама по себе, запрос - отрабатывает сам по себе.
А вместе - нет, потому и спрашиваю любого дельного совета.
6  Основные форумы / Вопросы по Excel и VBA / Получение интернет-ссылки от пользователя через форму : 26.11.2020, 18:27:39
Здравствуйте!

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

У меня есть "веб-запрос" который выдает на лист данные из вшитой в него ссылки:
Код: (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 не заложен необходимый функционал.
Пока найти подходящее решение не получается.

Буду рад любой помощи.
Заранее благодарю!
7  Основные форумы / Вопросы по Excel и VBA / Re:Добавление и удаление строк по нескольким условиям : 26.11.2020, 15:08:08
Дмитрий, спасибо за помощь!
Разобрался, внес изменения к себе, работает.
8  Основные форумы / Вопросы по Excel и VBA / Re:Добавление и удаление строк по нескольким условиям : 26.11.2020, 02:34:54
Товарищи специалисты, помогите, пожалуйста, дорешать задачку.
Пока получилось вот так:

Код: (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, то "без автора" также подставляется выше первой статьи, а это не нужно;
- "без автора" не ставится после последней строчки с названием статьи и без автора.

Вероятно, все это, конечно, решается весьма просто, но для меня, не программиста, даже эта простота представляет затруднения.
Еще раз спасибо за внимание и помощь.
9  Основные форумы / Вопросы по Excel и VBA / Re:Добавление и удаление строк по нескольким условиям : 25.11.2020, 19:16:22
Файл "пример" с таблицами (можно добавить вместо таблиц в первом сообщении).
10  Основные форумы / Вопросы по Excel и VBA / Добавление и удаление строк по нескольким условиям : 25.11.2020, 15:33:22
Здравствуйте, уважаемые специалисты!
Всем-всем-всем добра и хорошего настроения!

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

Имеется таблица в диапазоне "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.

Заранее благодарю за беспокойство.
11  Основные форумы / Вопросы по Excel и VBA / Re:Отображение процесса выполнения скрипта : 21.11.2020, 19:18:35
Большое спасибо! Улыбка
12  Основные форумы / Вопросы по Excel и VBA / Re:Отображение процесса выполнения скрипт : 21.11.2020, 15:29:07
Здорово, работает, СПАСИБО!
Это отличное решение - ставить "+1" после каждого шага, это корректно показывает общий процесс выполнения.

Только пара моментов:
У меня эксель 2016 и прогресс-бар - почему-то закрашен темно-зеленым цветом, и прогресса из-за этого почти и не видно. Это можно как-то поменять, чтобы был обычный цвет?
И если Вас не затруднит, скажите пожалуйста, а как это же самое применить к форме "UserForm" (из примера) для заливки серой полосы синим цветом?
13  Основные форумы / Вопросы по Excel и VBA / Отображение процесса выполнения скрипта : 21.11.2020, 00:17:14
Доброго времени суток, добрый люди!
Всем хорошего настроения, здоровья и благополучия!

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

В итоге, использовал форму 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 "Готово"
в конце.

Буду рад любой подсказке/помощи/доброму совету.
14  Основные форумы / Вопросы по Excel и VBA / Re:Текст с начала строки до спец. символа (или по маске) выделить жирным : 08.11.2020, 23:59:33
Супер! Спасибооо!
15  Основные форумы / Вопросы по Excel и VBA / Re:Текст с начала строки до спец. символа (или по маске) выделить жирным : 08.11.2020, 20:41:49
Действительно, это моя "недоработка"; Ваш скрипт корректно работает в "диапазоне заполненных ячеек".
С одной стороны, в моем случае 1000 - это сильно через край; в среднем количество обрабатываемых ячеек за 1 цикл, варьируется от 150 до 550. Т.е. с 1 строки (K2) и до последней заполненной (K540, например) - слеш / присутствует; а дальше начинаются пустые ячейки.
С другой стороны, чтобы постоянно не править руками этот параметр, имеет смысл оставить ну, хотя бы, 600; в ряде случаев этого будет достаточно. Ну а 1000 - это уж точно "наверняка".
Страниц: [1] 2
Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru