Тэги для vba excel - Word и Excel - помощь в работе с программами

Содержание

Свойство Form.Tag (Access)
Синтаксис
Замечания
Пример
Поддержка и обратная связь
Свойство OptionButton.Tag (Access)
Синтаксис
Замечания
Пример
Поддержка и обратная связь
Свойство IRibbonControl.Tag (Office)
Синтаксис
Возвращаемое значение
Замечания
Пример
См. также
Поддержка и обратная связь
Свойство TextBox.Tag (Access)
Синтаксис
Замечания
Пример
Поддержка и обратная связь
Свойство «Тег»
Применение
Замечания
Пример

Свойство Form.Tag (Access)

Хранит дополнительные сведения о форме, отчете, разделе или элементе управления, необходимых приложению Microsoft Access. Для чтения и записи, String.

Синтаксис

expression. Тег

выражение: переменная, представляющая объект Form.

Замечания

Можно ввести строковое выражение длиной до 2048 символов. По умолчанию используется строка нулевой длины (» «).

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

Используйте это свойство для назначения строки идентификации объекту, не влияя ни на какие из его других параметров свойства или не вызывая других побочных эффектов. Свойство Tag полезно, если необходимо проверить удостоверение формы, отчета, раздела или элемента управления, передаваемого в качестве переменной в процедуру.

Пример

В следующем примере свойство Tag используется для отображения пользовательских сообщений об элементах управления в форме. Когда элемент управления имеет фокус, описательный текст отображается в элементе управления label с именем lblMessage. Укажите текст сообщения, задав для свойства Tag для каждого элемента управления короткую текстовую строку. Когда элемент управления получает фокус, его свойство Tag назначается свойству Caption элемента управления меткой.

В этом примере отображается описательный текст текстового поля с именем txtDescription и кнопки команды с именем cmdButton в форме.

Поддержка и обратная связь

Есть вопросы или отзывы, касающиеся Office VBA или этой статьи? Руководство по другим способам получения поддержки и отправки отзывов см. в статье Поддержка Office VBA и обратная связь.

Источник

Свойство OptionButton.Tag (Access)

Синтаксис

expression. Тег

Выражение Переменная, представляющая объект OptionButton .

Замечания

Можно ввести строковое выражение длиной до 2048 символов. По умолчанию используется строка нулевой длины (» «).

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

Пример

Поддержка и обратная связь

Источник

Свойство IRibbonControl.Tag (Office)

Используется для хранения произвольных строк и их получения во время выполнения. Только для чтения.

Синтаксис

expression. Тег

Выражение Выражение, возвращающее объект IRibbonControl .

Возвращаемое значение

Замечания

Обычно можно различать элементы управления в XML-файле настройки пользовательского интерфейса ленты с помощью свойства Id . Однако существуют ограничения на то, что могут содержать идентификаторы (не буквенно-цифровые символы, и все они должны быть уникальными). Свойство Tag не имеет этих ограничений, поэтому его можно использовать в следующих ситуациях, когда идентификатор не работает:

Если необходимо сохранить специальную строку с элементом управления, например имя файла. Например: tag=»C:pathfile.xlsm».

Если вы хотите, чтобы процедуры обратного вызова обрабатывали несколько элементов управления одинаково, но вы не хотите поддерживать список всех их идентификаторов (которые должны быть уникальными). Например, можно использовать кнопки на разных вкладках на ленте с тегом «синий», а затем просто выбрать свойство Tag вместо свойства ID при выполнении некоторых общих действий.

Пример

В XML-коде, используемом для настройки пользовательского интерфейса ленты, можно задать тег следующим образом. При вызове действия MyFunction можно прочитать свойство Tag , которое будет равно «some string».

См. также

Поддержка и обратная связь

Источник

Свойство TextBox.Tag (Access)

Синтаксис

expression. Тег

Выражение Переменная, представляющая объект TextBox .

Замечания

Можно ввести строковое выражение длиной до 2048 символов. По умолчанию используется строка нулевой длины (» «).

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

Пример

Поддержка и обратная связь

Источник

Свойство «Тег»

Применение

Хранит дополнительные сведения о форма, отчет, страница доступа к данным, раздел или элемент управления, необходимых Microsoft Office Access 2007 приложении. Возвращает доступное для чтения и записи значение типа String.

выражение — обязательный аргумент. Выражение, которое возвращает один из объектов в списке «Применяется к».

Замечания

Можно ввести строковое выражение, которое содержит до 2048 знаков. По умолчанию используется пустая строка (» «).

Это свойство можно задать с помощью страницы свойств объекта, макроса или кода Visual Basic для приложений (VBA).

В отличие от других свойств, значение свойства Tag (Тег) не влияет на атрибуты объекта.

Это свойство используется для назначения строки идентификатора объекту без воздействия на любые другие значения его свойств или других побочных эффектов. Свойство Tag удобно использовать для проверки идентификаторов формы, отчета, страницы доступа к данным, раздела или элемента управления, передаваемых в процедуру в качестве переменной.

Пример

В следующем примере свойство Tag используется для отображения пользовательских сообщений об элементах управления в форме. Когда элемент управления получает фокус, в элементе управления надписи отображается текстовое описание lblMessage . Для свойства Tag каждого элемента управления задается короткая текстовая строка, определяющая текст этого сообщения. Когда элемент управления получает фокус, его свойство Tag назначается свойству Caption (Подпись) элемента управления надписи. В этом примере в форме отображается текстовое описание для поля txtDescription и кнопки cmdButton .

Источник

excel-vba refers to VBA when specifically applied to Excel. vba is more generic and specifically reference to VBA in any application (Outlook, Word, Access)

excel is a different tag is while it could refer to Excel and VBA, it could also refer to Excel on its own. While asking about specific formulas in excel, there are some questions that have been accepted in the past, although generally they are more accepted on Super User.

In the end, all 3 tags reference slight different things and may not necessarily be the same thing.

Ultimately, excel-vba is a separate tag for historical reasons. Is it closely related to vba? Absolutely, but it the Excel implementation happens to be one of the most common and is very wildly used in business on a regular basis. I hate using VBA in Excel (if I am going to use a Microsoft developed language, give me a .Net language any day of the week and 45 times on Monday), but because the IDE is so widely available, I program with it daily. And because there is so many specific functions and methods for Excel, VBA in Excel happens to common and probably deserves its own tag

Источник

12 / 12 / 5

Регистрация: 15.11.2010

Сообщений: 256

20.11.2010, 20:23. Показов 4094. Ответов 4

text1.tag ? что за свойства ?
Кому не лень дайте сссылки на книжки где есть опесания всех свойст элементов управление! или вложите буду благодарен

Programming

Эксперт

94731 / 64177 / 26122

Регистрация: 12.04.2006

Сообщений: 116,782

20.11.2010, 20:23

Ответы с готовыми решениями:

Как использовать свойство Tag для ListBox ?
Подскажите, как использовать свойство Tag для ListBox ? Например, в Листе показаны имена…

Свойство tag
Здравствуйте!

У меня создаютса динамически image на форме.
У каждной групы етих image есть свой…

свойство Tag
FormMas:=TfmRangPersonal.Create(nil);
if not Modal then
…

Свойство кнопки Tag
видел где то как используют различные состояния кнопки в зависимости от ситуации
с помощью…

1 / 1 / 0

Регистрация: 16.11.2010

Сообщений: 21

20.11.2010, 20:36

Купи книжку, так будет полезнее

12 / 12 / 5

Регистрация: 15.11.2010

Сообщений: 256

20.11.2010, 20:38

[ТС]

Дома куча книги …..

gaw

6644 / 1511 / 169

Регистрация: 09.01.2010

Сообщений: 4,298

20.11.2010, 20:45

как бы мгновенный признак, использование от фантазии и потребностей
пр-р

Visual Basic

Private Sub Command1_Click()
Label1.Caption = Text1.Tag
End Sub
 
Private Sub Text1_Change()
 
If Text1.Text = "123" Then
Text1.Tag = "123"
Else
Text1.Tag = "no 123"
End If
Label1.Caption = Text1.Tag
End Sub
 
Private Sub Text1_Click()
Text1.Tag = 8
End Sub
 
Private Sub Text1_DblClick()
Text1.Tag = "jj"
End Sub

1904 / 781 / 31

Регистрация: 11.02.2010

Сообщений: 1,567

21.11.2010, 01:14

Tag — просто тег для формы. Можно считать его просто пользовательским атрибутом, который доступен только из программы и ни на что не влияет. Обычно используется для хранения служебной информации (например, меток). Принимает строковое значение с максимальной длиной 2048 символов.

вот сдесь https://www.cyberforum.ru/ms-a… 90939.html, например, предлагается использовать свойство Tag для запоминания начальных значений поля и определения факта внесения изменений

Источник

Nice! Very slick.

I was disappointed that Excel doesn’t let us paste to a merged cell and also pastes results containing a break into successive rows below the «target» cell though, as that meant it simply doesn’t work for me. I tried a few tweaks (unmerge/remerge, etc.) but then Excel dropped anything below a break, so that was a dead end.

Ultimately, I came up with a routine that’ll handle simple tags and not use the «native» Unicode converter that is causing the issue with merged fields. Hope others find this useful:

Public Sub AddHTMLFormattedText(rngA As Range, strHTML As String, Optional blnShowBadHTMLWarning As Boolean = False)
    ' Adds converts text formatted with basic HTML tags to formatted text in an Excel cell
    ' NOTE: Font Sizes not handled perfectly per HTML standard, but I find this method more useful!

    Dim strActualText As String, intSrcPos As Integer, intDestPos As Integer, intDestSrcEquiv() As Integer
    Dim varyTags As Variant, varTag As Variant, varEndTag As Variant, blnTagMatch As Boolean
    Dim intCtr As Integer
    Dim intStartPos As Integer, intEndPos As Integer, intActualStartPos As Integer, intActualEndPos As Integer
    Dim intFontSizeStartPos As Integer, intFontSizeEndPos As Integer, intFontSize As Integer

    varyTags = Array("<b>", "</b>", "<i>", "</i>", "<u>", "</u>", "<sub>", "</sub>", "<sup>", "</sup>")

    ' Remove unhandled/unneeded tags, convert <br> and <p> tags to line feeds
    strHTML = Trim(strHTML)
    strHTML = Replace(strHTML, "<html>", "")
    strHTML = Replace(strHTML, "</html>", "")
    strHTML = Replace(strHTML, "<p>", "")
    While LCase(Right$(strHTML, 4)) = "</p>" Or LCase(Right$(strHTML, 4)) = "<br>"
        strHTML = Left$(strHTML, Len(strHTML) - 4)
        strHTML = Trim(strHTML)
    Wend
    strHTML = Replace(strHTML, "<br>", vbLf)
    strHTML = Replace(strHTML, "</p>", vbLf)

    strHTML = Trim(strHTML)

    ReDim intDestSrcEquiv(1 To Len(strHTML))
    strActualText = ""
    intSrcPos = 1
    intDestPos = 1
    Do While intSrcPos <= Len(strHTML)
        blnTagMatch = False
        For Each varTag In varyTags
            If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
                blnTagMatch = True
                intSrcPos = intSrcPos + Len(varTag)
                If intSrcPos > Len(strHTML) Then Exit Do
                Exit For
            End If
        Next
        If blnTagMatch = False Then
            varTag = "<font size"
            If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
                blnTagMatch = True
                intEndPos = InStr(intSrcPos, strHTML, ">")
                intSrcPos = intEndPos + 1
                If intSrcPos > Len(strHTML) Then Exit Do
            Else
                varTag = "</font>"
                If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
                    blnTagMatch = True
                    intSrcPos = intSrcPos + Len(varTag)
                    If intSrcPos > Len(strHTML) Then Exit Do
                End If
            End If
        End If
        If blnTagMatch = False Then
            strActualText = strActualText & Mid$(strHTML, intSrcPos, 1)
            intDestSrcEquiv(intSrcPos) = intDestPos
            intDestPos = intDestPos + 1
            intSrcPos = intSrcPos + 1
        End If
    Loop

    ' Clear any bold/underline/italic/superscript/subscript formatting from cell
    rngA.Font.Bold = False
    rngA.Font.Underline = False
    rngA.Font.Italic = False
    rngA.Font.Subscript = False
    rngA.Font.Superscript = False

    rngA.Value = strActualText

    ' Now start applying Formats!"
    ' Start with Font Size first
    intSrcPos = 1
    intDestPos = 1
    Do While intSrcPos <= Len(strHTML)
        varTag = "<font size"
        If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
            intFontSizeStartPos = InStr(intSrcPos, strHTML, """") + 1
            intFontSizeEndPos = InStr(intFontSizeStartPos, strHTML, """") - 1
            If intFontSizeEndPos - intFontSizeStartPos <= 3 And intFontSizeEndPos - intFontSizeStartPos > 0 Then
                Debug.Print Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
                If Mid$(strHTML, intFontSizeStartPos, 1) = "+" Then
                    intFontSizeStartPos = intFontSizeStartPos + 1
                    intFontSize = 11 + 2 * Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
                ElseIf Mid$(strHTML, intFontSizeStartPos, 1) = "-" Then
                    intFontSizeStartPos = intFontSizeStartPos + 1
                    intFontSize = 11 - 2 * Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
                Else
                    intFontSize = Mid$(strHTML, intFontSizeStartPos, intFontSizeEndPos - intFontSizeStartPos + 1)
                End If
            Else
                ' Error!
                GoTo HTML_Err
            End If
            intEndPos = InStr(intSrcPos, strHTML, ">")
            intSrcPos = intEndPos + 1
            intStartPos = intSrcPos
            If intSrcPos > Len(strHTML) Then Exit Do
            While intDestSrcEquiv(intStartPos) = 0 And intStartPos < Len(strHTML)
                intStartPos = intStartPos + 1
            Wend
            If intStartPos >= Len(strHTML) Then GoTo HTML_Err ' HTML is bad!
            varEndTag = "</font>"
            intEndPos = InStr(intSrcPos, LCase(strHTML), varEndTag)
            If intEndPos = 0 Then GoTo HTML_Err ' HTML is bad!
            While intDestSrcEquiv(intEndPos) = 0 And intEndPos > intSrcPos
                intEndPos = intEndPos - 1
            Wend
            If intEndPos > intSrcPos Then
                intActualStartPos = intDestSrcEquiv(intStartPos)
                intActualEndPos = intDestSrcEquiv(intEndPos)
                rngA.Characters(intActualStartPos, intActualEndPos - intActualStartPos + 1) _
                    .Font.Size = intFontSize
            End If
        End If
        intSrcPos = intSrcPos + 1
    Loop

    'Now do remaining tags
    intSrcPos = 1
    intDestPos = 1
    Do While intSrcPos <= Len(strHTML)
        If intDestSrcEquiv(intSrcPos) = 0 Then
            ' This must be a Tag!
            For intCtr = 0 To UBound(varyTags) Step 2
                varTag = varyTags(intCtr)
                intStartPos = intSrcPos + Len(varTag)
                While intDestSrcEquiv(intStartPos) = 0 And intStartPos < Len(strHTML)
                    intStartPos = intStartPos + 1
                Wend
                If intStartPos >= Len(strHTML) Then GoTo HTML_Err ' HTML is bad!
                If LCase(Mid$(strHTML, intSrcPos, Len(varTag))) = varTag Then
                    varEndTag = varyTags(intCtr + 1)
                    intEndPos = InStr(intSrcPos, LCase(strHTML), varEndTag)
                    If intEndPos = 0 Then GoTo HTML_Err ' HTML is bad!
                    While intDestSrcEquiv(intEndPos) = 0 And intEndPos > intSrcPos
                        intEndPos = intEndPos - 1
                    Wend
                    If intEndPos > intSrcPos Then
                        intActualStartPos = intDestSrcEquiv(intStartPos)
                        intActualEndPos = intDestSrcEquiv(intEndPos)
                        With rngA.Characters(intActualStartPos, intActualEndPos - intActualStartPos + 1).Font
                            If varTag = "<b>" Then
                                .Bold = True
                            ElseIf varTag = "<i>" Then
                                .Italic = True
                            ElseIf varTag = "<u>" Then
                                .Underline = True
                            ElseIf varTag = "<sup>" Then
                                .Superscript = True
                            ElseIf varTag = "<sub>" Then
                                .Subscript = True
                            End If
                        End With
                    End If
                    intSrcPos = intSrcPos + Len(varTag) - 1
                    Exit For
                End If
            Next
        End If
        intSrcPos = intSrcPos + 1
        intDestPos = intDestPos + 1
    Loop
Exit_Sub:
    Exit Sub
HTML_Err:
    ' There was an error with the Tags. Show warning if requested.
    If blnShowBadHTMLWarning Then
        MsgBox "There was an error with the Tags in the HTML file. Could not apply formatting."
    End If
End Sub

Note this doesn’t care about tag nesting, instead only requiring a close tag for every open tag, and assuming the close tag nearest the opening tag applies to the opening tag. Properly nested tags will work fine, while improperly nested tags will not be rejected and may or may not work.

Источник

4.3. Label

Элемент управления label (Метка) используется лишь для вывода подписей к другим элементам управления. Обычно ему не назначают никаких обработчиков событий

4.4. CommandButton

Элемент управления CommandButton (Кнопка) обычно используют для выполнения каких-либо команд. Основное событие кнопки — Click (Щелчок). Оно генерируется при щелчке по кнопке.

Кнопка может воспринимать и другие события — всего их больше десятка. Обычно об их предназначении можно узнать из их же названий. Например, очевидно, что название события MouseMove переводится как «Перемещение указателя мыши». Это событие будет генерироваться всякий раз, когда над кнопкой будет перемещаться указатель мыши. Ниже мы напишем программу, работа которой будет основана на этом событии.

4.5. TextBox

04-02-Текстовое поле.docm — пример к п. 4.5.

TextBox — текстовое поле. Обычно используется для ввода данных пользователем. Текст, который введен в текстовое поле, можно получить или изменить, воспользовавшись его свойством Text. Текстовым полям нечасто назначают события, однако, например, для проверки введенных данных сразу после ввода, можно использовать событие Change (Изменение). Оно генерируется всякий раз, когда содержимое поля меняется.

Рассмотрим пример. Создадим форму и добавим на нее два элемента управления — текстовое поле txt_First и надпись lbl_First. Установим у lbl_First свойство BorderStyle в fmBorderStyleSingle — благодаря этому вокруг надписи будет отображаться граница. Можете так же добавить пару пояснительных надписей к txt_First и lbl_First.

Сделаем двойной щелчок по текстовому полю. Откроется окно редактора кода с открытым обработчиком события Change. Добавим в обработчик такой код:

lbl_First.Caption = txt_First.TextLength

Вам знакомы почти все элементы этого кода кроме свойства текстового поля TextLength. Это свойство позволяет узнать, сколько символов содержится в поле. Запустите программу. Попытайтесь ввести что-нибудь в поле с клавиатуры — по мере ввода символов в текстовое поле, их количество будет отображаться на lbl_First (рис. 4.4.).

Рис.
4.4.
Работа с текстовым полем

4.6. ComboBox

04-03-Поле со списком.docm — пример к п. 4.6.

ComboBox — поле со списком. Используется для хранения списков значений. Поле следует заполнить перед использованием. Для добавления новых значений используется метод AddItem (Добавить элемент). Обычно вызовы этого метода помещают в обработчик события Initialize формы, на которой расположено поле.

Для очистки поля можно использовать метод Clear (Очистить).

После того, как пользователь выбрал один из параметров поля, считать выбранное значение можно, воспользовавшись свойством Value.

После того, как пользователь сделал выбор из поля со списком, выбранное значение обрабатывается по нажатию какой-либо кнопки. Можно также воспользоваться событием Change (Изменение).

Рассмотрим пример использования элемента управления ComboBox. Заполним его списком фамилий, а при выборе фамилии из списка, будем выводить ее в окне сообщения.

Создадим форму frm_Main, расположим на ней поле со списком, назовем его cbo_First. Теперь создадим обработчик события Initialize для frm_Main и добавим туда такой код (листинг 4.2):

cbo_First.AddItem ("Иванов")
cbo_First.AddItem ("Петров")
cbo_First.AddItem ("Сидоров")
cbo_First.AddItem ("Васильев")

Листинг
4.2.
Код обработчика события Initialize для frm_Main

Создадим обработчик события Change для cbo_First и добавим в него команду вывода сообщения:

Теперь запустим форму (рис. 4.5.). При нажатии на кнопку с треугольником, поле раскрывается, при выборе одной из строк поля, ее значение отображается в окне сообщения.

Рис.
4.5.
Работа с ComboBox

4.7. ListBox

04-04-Cписок.docm — пример к п. 4.7.

ListBox — список. Обычно используется для представления списков данных.

Работа с ListBox аналогична работе с ComboBox. На рис. 4.6. вы можете видеть форму с расположенным на ней списком, реализующую ту же функциональность, что и в примере к полю со списком.

Рис.
4.6.
Работа с ListBox

4.8. CheckBox

04-05-Флажок.docm — пример к п. 4.8.

CheckBox — флажок. Используется для включения и отключения каких-либо опций. Элемент управления представляет собой поле, где можно устанавливать и снимать флажок и надпись, где обычно выводится название и назначение флажка.

Если флажок установлен — его свойство Value (Значение) устанавливается в True (Истина), если не установлен — в False (Ложь). Для того чтобы программно установить или снять флажок, можно воспользоваться его свойством Value, приравняв ему True или False, соответственно.

Еще одно важное свойство флажка — TripleState. Если оно включено — флажок помимо True или False может иметь значение Null, которое можно интерпретировать как «Пустой флажок». Null-флажок нельзя модифицировать — он закрашен серым цветом.

Сами по себе, без использования специальных конструкций языка, флажки приносят мало пользы. Эффективно работать с ними можно, используя операторы принятия решений.

С флажком можно сопоставить событие Change (Изменить). Оно выполняется всякий раз при установке или снятии флажка.

Давайте рассмотрим пример работы с флажками. Создадим форму frm_First и разместим на ней три флажка – chk_1, chk_2 и chk_3. Добавим на форму пару кнопок – cmd_SetAll с надписью «Установить все флажки» и cmd_ClearAll с надписью «Снять все флажки». Думаю, вы видели что-то подобное во многих программах — часто пользователю предоставляется возможность не кликать по множеству флажков вручную, устанавливая или снимая их, а сделать эту работу одним нажатием специальной кнопки. Точно так же, можно создать кнопку, которая устанавливает определенный набор флажков из всех, реализуя тем самым какую-нибудь особенную настройку программы.

Добавим обработчик события Click для cmd_SetAll (листинг 4.3). Если попытаться выразить обычным языком то, что должно произойти по нажатию этой кнопки, то получится следующее: «Установить все три флажка, то есть, сделать их параметр Value равным True«.

chk_1.Value = True
chk_2.Value = True
chk_3.Value = True

Листинг
4.3.
Обработчик события Click для cmd_SetAll

Рассуждая аналогично, пишем код для события Click кнопки cmd_ClearAll (листинг 4.4). Очевидно, что единственное его отличие от предыдущего кода заключается в смене True на False.

chk_1.Value = False
chk_2.Value = False
chk_3.Value = False

Листинг
4.4.
Обработчик события Click для cmd_ClearAll

На рис. 4.7. вы можете видеть запущенную форму.

Рис.
4.7.
Интерфейс с использованием CheckBox

Источник

Интернет
Разное

В данной статье приведён код 2 функций, которые позволят вам найти на веб-странице нужные HTML теги,
и преобразовать HTML в текст

Особенность этого кода, — использование регулярных выражений (Regexp) для поиска в HTML

Эти функции лежат в основе моей надстройки «Парсер сайтов»

Пример использования:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' ищем div id="mod-lists", и берем его начинку (innerHTML)
' Индекс 1 после innerHTML означает, что если будет найдено несколько таких тегов, - макрос возьмет только первый
res = GetTags(txt, "div", "id", "mod-lists", "innerHTML 1")
 
 
' ищем ВСЕ теги span класса product (функция вернёт массив значений в переменную arr)
arr = Split(GetTags(txt, "span", "class", "product", "outerHTML"), ARSEP)
 
 
' ищем гиперссылку (тег a класса blue-link), и возвращаем атрибут href
link$ = GetTags(txt, "a", "class", "blue-link", "href")
 
 
' ищем ЛЮБОЙ ТЕГ класса price, и берем последний найденный (last), преобразовав его в текст (ConvertToText)
price = GetTags(txt, "any tag", "class", "price", "ConvertToText last")

Есть возможность удалять теги из HTML (параметр DeleteTags), а также использовать подстановочный символ * до или после значения атрибута.
Можно также выполнять поиск по маске для атрибутов:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' удаляем все div, где имя класса начинается с old
txt = GetTags(txt, "div", "class", "old*", "DeleteTags")
 
 
' ищем ВСЕ гиперссылки по маске /item/
links_array = Split(GetTags(txt, "a", "AttributesPattern", "*/item/*", "href"), ARSEP)

Функцией преобразования HTML в текст (ConvertHTMLtoText) можно воспользоваться отдельно (без функции GetTags)

Весь приведённый ниже код, скопируйте в отдельный стандартный модуль

'---------------------------------------------------------------------------------------
' Module        : modHTML                          excelvba.ru/programmes/Parser
' Author        : Igor Vakhnenko                   Date: 21.02.2016
' info @ excelvba.ru                               Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Const ARSEP$ = "%~$"
 
Function REGEXP()
    On Error Resume Next
    Static REGEXP_ As Object
    If REGEXP_ Is Nothing Then Set REGEXP_ = CreateObject("VBScript.RegExp"): REGEXP_.Global = True
    Set REGEXP = REGEXP_
End Function
 
Function GetTags(ByVal txt$, ByVal TagName$, Optional ByVal AttrName$, Optional ByVal AttrValue$, Optional ByVal Result$ = "outerHTML") As String
    ' функция выполняет поиск заданного HTML-тега (или атрибута тега) в HTML коде
    On Error Resume Next
    Dim res$, Pattern$, SelfClosing As Boolean, NeedContent As Boolean, ResultType$, ResultIndex$, ResultsCount&, ind&
    Dim PatternPrefix$, PatternSuffix$, AttrValuePattern$, Add_URL_Prefix$
    Const SelfClosingTags = ",area,base,basefont,br,col,frame,hr,img,input,isindex,link,meta,param,embed,"
    Const ASTERISK_PATTERN = "[A-Za-z0-9_-]*"
    AttrName$ = Trim(AttrName$): AttrValue$ = Trim(AttrValue$): TagName$ = Trim(TagName$)
    If TagName$ = "Any Tag" Then TagName$ = "[a-zA-Z1-6]+"
    If TagName$ = "" Then GetTags = "GetTags ERROR: 'TagName' parameter is blank": Exit Function
 
    If InStr(1, AttrValue$, "*") Then
        If AttrValue$ Like "[*]*" Then AttrValue$ = ASTERISK_PATTERN & Mid(AttrValue$, 2)
        If AttrValue$ Like "*[A-Za-z0-9_-][*]" Then AttrValue$ = Left(AttrValue$, Len(AttrValue$) - 1) & ASTERISK_PATTERN
    End If

    PatternPrefix$ = "<(" & TagName$ & ")b"
    PatternSuffix$ = "[^>]*>"
    Select Case True
        Case AttrName$ & AttrValue$ = ""        ' поиск заданных тегов
            Pattern$ = PatternPrefix$ & PatternSuffix$
 
        Case AttrName$ = "AttributesPattern"        ' поиск тега по шаблону regexp для его заголовка
            If InStr(1, AttrValue$, ">") + InStr(1, AttrValue$, "<") Then _
               GetTags = "GetTags ERROR: 'AttributeValue' parameter contains unacceptable symbols ('<' or '>')": Exit Function
            Pattern$ = PatternPrefix$ & "[^>]*" & AttrValue$ & PatternSuffix$
 
        Case Else        ' поиск тегов по атрибуту name / id / class
            AttrValuePattern$ = "(?:(?:" & AttrValue$ & "b)|(?:['""](|[^<>'""]* )b" & AttrValue$ & "b(| [^<>'""]*)['""]))"
            Pattern$ = PatternPrefix$ & "[^>]*b" & AttrName$ & "s*=s*" & AttrValuePattern$ & PatternSuffix$
    End Select
 
    Result$ = Application.Trim(Result$): If Result$ = "" Then GetTags = "GetTags ERROR: 'Result' parameter is blank": Exit Function
    ResultType$ = Split(Result$)(0)
    ResultIndex$ = Split(Result$, , 2)(1)
 
 
    SelfClosing = SelfClosingTags Like "*," & TagName$ & ",*"
    NeedContent = InStr(1, "|innerHTML|outerHTML|ConvertToText|DeleteTags|", "|" & ResultType$ & "|") > 0
 
    Dim v, content$, cnt&, i&, TextAfterHeader$, TagHeader$, attr$, txtlen&, NN&
    With REGEXP
        .IgnoreCase = True: .Pattern = Pattern$
StartSearching:
        If .test(txt) Then
            For Each v In .Execute(txt)
                DoEvents
                TagHeader$ = "": TagHeader$ = v.Value
 
                If NeedContent And Not SelfClosing Then
                    TagName$ = v.submatches.Item(0)
                    TextAfterHeader$ = "": TextAfterHeader$ = Mid(txt, v.FirstIndex + Len(TagHeader$) + 1)
                    content$ = GetTagInnerHTML(TextAfterHeader$, TagName$)
                    If (ResultType$ = "outerHTML") Or (ResultType$ = "DeleteTags") Then
                        content$ = TagHeader$ & content$ & "</" & TagName$ & ">"
                    End If
                Else
                    content$ = TagHeader$
                End If

                Select Case ResultType$
                    Case "innerHTML", "outerHTML", "TagHeaderOnly"        ' do nothing
                    Case "DeleteTags"
                        txtlen& = Len(txt): txt = Replace(txt, content$, "")
                         ' защита от зацикливания, - если замена не выполнилась, то больше не пытаемся
                       content$ = "": If Len(txt) < txtlen& Then GoTo StartSearching
                    Case "ConvertToText"        ' convert to text
                        content$ = ConvertHTMLtoText(content$)
                    Case Else        ' get attribute value
                        attr$ = "": content$ = Split(content$, ">")(0)
                        content$ = Replace(Replace(content$, "= ", "="), " =", "=")
                        attr$ = Trim(Split(content$, " " & ResultType$ & "=", 2)(1))
                        Select Case Mid(attr$, 1, 1)
                            Case """", "'": attr$ = Split(attr$, Mid(attr$, 1, 1))(1)
                            Case Else: attr$ = Split(attr$, " ")(0)
                        End Select
                        content$ = ConvertHTMLtoText(attr$)        ' для замены  &amp; на & (и подобных других замен)
                       
                End Select
 
                If Len(content$) Then
                    ResultsCount& = ResultsCount& + 1
                    GetTags = GetTags & IIf(Len(GetTags), ARSEP, "") & content$
                    If Val(ResultIndex$) Then If Val(ResultIndex$) = ResultsCount& Then GetTags = content$: Exit Function
                End If
            Next
        End If
    End With
 
    If ResultType$ = "DeleteTags" Then GetTags = txt: Exit Function
 
    If ResultIndex$ = "join" Then GetTags = Replace(GetTags, ARSEP, vbNewLine): Exit Function
 
    If Len(ResultIndex$) * Len(GetTags) Then        ' если указан номер элемента массива
        If InStr(1, ResultIndex$, "last", vbTextCompare) > 0 Then
            ind& = UBound(Split(GetTags, ARSEP)) + Val(Split(ResultIndex$, "last")(1))
        Else
            ind& = Fix(Val(ResultIndex$)) - 1
        End If
 
        If ind& >= 0 And ind& <= UBound(Split(GetTags, ARSEP)) Then
            GetTags = Split(GetTags, ARSEP)(ind&)
        Else
            GetTags = ""
        End If
    End If
End Function

Function GetTagInnerHTML(ByVal txt$, ByVal TagName$) As String
    On Error Resume Next
    Dim ClosingTag$, arr, i&, nOPENING&
    ClosingTag$ = "</" & TagName$ & ">"
    If InStr(1, txt, ClosingTag$, vbTextCompare) = 0 Then Exit Function
    arr = Split(txt, ClosingTag$, , vbTextCompare)
    For i = LBound(arr) To UBound(arr) - 1        ' если убрать -1, то будет выводить и содержимое незакрытого тега (до конца текста в txt$)
        If Len(arr(i)) Then
            nOPENING& = nOPENING& + UBound(Split(arr(i), "<" & TagName$ & ">")) + UBound(Split(arr(i), "<" & TagName$ & " "))
        End If
        GetTagInnerHTML = GetTagInnerHTML & arr(i) & IIf(nOPENING& <> i, ClosingTag$, "")
        If nOPENING& = i Then Exit Function
    Next i
    GetTagInnerHTML = ""
End Function

Function ConvertHTMLtoText(ByVal txt$, Optional RemoveExtraLF As Boolean = False) As String
    ' Функция преобразует HTML в текст без использования DOM
    ' Создание функции было обусловлено утечками памяти при использовании библиотеки MSHTML
    On Error Resume Next
    Const HTML_SP$ = "nbsp=32;pound=163;euro=8364;para=182;sect=167;copy=169;reg=174;trade=8482;deg=176;plusmn=177;frac14=188;frac12=189;" & _
          "frac34=190;times=215;divide=247;fnof=402;Alpha=913;Beta=914;Gamma=915;Delta=916;Epsilon=917;Zeta=918;Eta=919;Theta=920;" & _
          "Iota=921;Kappa=922;Lambda=923;Mu=924;Nu=925;Xi=926;Omicron=927;Pi=928;Rho=929;Sigma=931;Tau=932;Upsilon=933;Phi=934;" & _
          "Chi=935;Psi=936;Omega=937;alpha=945;beta=946;gamma=947;delta=948;epsilon=949;zeta=950;eta=951;theta=952;iota=953;kappa=954;" & _
          "lambda=955;mu=956;nu=957;xi=958;omicron=959;pi=960;rho=961;sigma=963;tau=964;upsilon=965;phi=966;chi=967;psi=968;omega=969;" & _
          "sigmaf=962;larr=8592;uarr=8593;rarr=8594;darr=8595;harr=8596;spades=9824;clubs=9827;hearts=9829;" & _
          "diams=9830;quot=34;amp=38;lt=60;gt=62;hellip=8230;prime=8242;ndash=8211;mdash=8212;lsquo=8216;rsquo=8217;sbquo=8218;" & _
          "ldquo=8220;rdquo=8221;bdquo=8222;laquo=171;raquo=187;ensp=8194;emsp=8195;shy=173;ordm=186;ordf=170;permil=8240;brvbar=166;" & _
          "micro=181;oline=8254;acute=180;sup1=185;sup2=178;sup3=179;not=172;frasl=8260;minus=8722;le=8804;ge=8805;asymp=8776;ne=8800;" & _
          "equiv=8801;radic=8730;infin=8734;sum=8721;prod=8719;part=8706;int=8747;forall=8704;exist=8707;empty=8709;Oslash=216;" & _
          "isin=8712;notin=8713;ni=8727;sub=8834;sup=8835;nsub=8836;sube=8838;supe=8839;oplus=8853;otimes=8855;perp=8869;ang=8736;" & _
          "and=8743;or=8744;cap=8745;cup=8746;cent=162;current=164;yen=165;bull=8226;middot=183;loz=9674;crarr=8629"
 
    Const ADD_TAB$ = "</th><th>,</td><td>"
    Const ADD_NL$ = "<div>,<p>,<table>,</table>,<img>,<h1>,<h2>,<h3>,<h4>,<h5>,<h6>,<br>,<hr>,</tr>,</li>,<dl>,<dt>"
 
    Dim Tag, char, arr, cnt&, i&
    With REGEXP
 
        ' удаляем все комменты из HTML
        If txt$ Like "*<!--*-->*" Then
            arr = "": arr = Split(txt, "<!--")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "-->"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "-->")(cnt&)
            Next i
            txt = Join(arr, "")
        End If

        txt$ = CloseUnclosedTags(txt$)
        ' очистка тегов
        .Pattern = "(<[A-Za-z1-6]+)[^<>]*(>)"
        txt$ = .Replace(txt$, "$1$2")        ' удаляем все атрибуты у тегов
        .Pattern = ">s*<"
        txt$ = .Replace(txt$, "><")        ' удаляем пробелы и переводы строк между тегами

        ' удаляем все скрипты
        If txt$ Like "*<script>*</script>*" Then
            arr = "": arr = Split(txt, "<script>")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "</script>"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "</script>")(cnt&)
            Next i
            txt = Join(arr, "")
        End If
 
        ' берём содержимое тега <body>
        If txt Like "*<body>*" Then txt = Split(txt, "<body>")(1)
 
        txt = Replace(txt, vbNewLine, vbLf): txt = Replace(txt, vbLf, vbNewLine)
        MultiReplace txt, "<br>" & vbNewLine, "<br>"
        MultiReplace txt, vbNewLine & "<br>", "<br>"
 
        ' добавляем переводы строк и табуляцию между ячейками таблиц
        For Each Tag In Split(ADD_NL$, ",")
            txt = Replace(txt, Tag, vbNewLine, , , vbTextCompare)
        Next Tag
        For Each Tag In Split(ADD_TAB$, ",")
            txt = Replace(txt, Tag, vbTab, , , vbTextCompare)
        Next Tag
 
        ' удаляем оставшиеся теги
        .Pattern = "<[^<>]+>"
        txt$ = .Replace(txt$, "")

        ' заменяем коды спецсимволов на сами символы
        For Each char In Split(HTML_SP$, ";")        ' сначала - символы, которые имеют названия типа &сopy; и &nbsр;
            If InStr(1, txt$, Split(char, "=")(0), vbBinaryCompare) Then
                txt$ = Replace(txt$, "&" & Split(char, "=")(0) & ";", ChrW(Val(Split(char, "=")(1))), , , vbBinaryCompare)
            End If
        Next char
        .Pattern = "&#(d{2,5});"        ' а теперь - спецсимволы, представленные кодами вида &#84l0;
        If .test(txt$) Then
            For Each char In .Execute(txt)
                txt$ = Replace(txt$, char.Value, ChrW(Val(char.submatches.Item(0))))
            Next
        End If
 
        ' убираем лишние переводы строк, пробелы и табуляторы
        MultiReplace txt, " " & vbTab, vbTab: MultiReplace txt, vbTab & " ", vbTab
        MultiReplace txt, vbTab & vbNewLine, vbNewLine: MultiReplace txt, vbNewLine & vbTab, vbNewLine
        MultiReplace txt$, vbNewLine & vbNewLine & vbNewLine, vbNewLine & vbNewLine
        MultiReplace txt, vbNewLine & " " & vbNewLine, vbNewLine
        MultiReplace txt, " " & vbNewLine, vbNewLine
 
        If RemoveExtraLF Then MultiReplace txt$, vbNewLine & vbNewLine, vbNewLine
 
        While txt$ Like "*" & vbNewLine: txt = Left(txt, Len(txt) - Len(vbNewLine)): Wend
        While txt$ Like vbNewLine & "*": txt = Mid(txt, Len(vbNewLine) + 1): Wend
 
    End With
    Erase arr: Err.Clear
    ConvertHTMLtoText = txt$
End Function

Sub MultiReplace(ByRef txt$, ByVal Find$, ByVal Replacement$)
    On Error Resume Next: Dim n&
    If InStr(1, Replacement$, Find$, vbBinaryCompare) Then Exit Sub        ' чтобы избежать зацикливания и переполнения
    While (InStr(1, txt$, Find$, vbBinaryCompare) > 0) And (n < 100)
        n = n + 1: txt$ = Replace(txt$, Find$, Replacement$)
    Wend
End Sub
 
Function CloseUnclosedTags(ByVal txt$) As String
    On Error Resume Next: CloseUnclosedTags = txt$: Dim char
    With REGEXP
        .Pattern = "(<[A-Za-z1-6]+b[^<>]*)(<[A-Za-z1-6]+b)"
        If .test(txt$) Then CloseUnclosedTags = .Replace(txt$, "$1>$2")
    End With
End Function

22869 просмотров

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Источник

Время на прочтение
7 мин

Количество просмотров 312K

Приветствую всех.

В этом посте я расскажу, что такое VBA и как с ним работать в Microsoft Excel 2007/2010 (для более старых версий изменяется лишь интерфейс — код, скорее всего, будет таким же) для автоматизации различной рутины.

VBA (Visual Basic for Applications) — это упрощенная версия Visual Basic, встроенная в множество продуктов линейки Microsoft Office. Она позволяет писать программы прямо в файле конкретного документа. Вам не требуется устанавливать различные IDE — всё, включая отладчик, уже есть в Excel.

Еще при помощи Visual Studio Tools for Office можно писать макросы на C# и также встраивать их. Спасибо, FireStorm.

Сразу скажу — писать на других языках (C++/Delphi/PHP) также возможно, но требуется научится читать, изменять и писать файлы офиса — встраивать в документы не получится. А интерфейсы Microsoft работают через COM. Чтобы вы поняли весь ужас, вот Hello World с использованием COM.

Поэтому, увы, будем учить Visual Basic.

Чуть-чуть подготовки и постановка задачи

Итак, поехали. Открываем Excel.

Для начала давайте добавим в Ribbon панель «Разработчик». В ней находятся кнопки, текстовые поля и пр. элементы для конструирования форм.

Появилась вкладка.

Теперь давайте подумаем, на каком примере мы будем изучать VBA. Недавно мне потребовалось красиво оформить прайс-лист, выглядевший, как таблица. Идём в гугл, набираем «прайс-лист» и качаем любой, который оформлен примерно так (не сочтите за рекламу, пожалуйста):

То есть требуется, чтобы было как минимум две группы, по которым можно объединить товары (в нашем случае это будут Тип и Производитель — в таком порядке). Для того, чтобы предложенный мною алгоритм работал корректно, отсортируйте товары так, чтобы товары из одной группы стояли подряд (сначала по Типу, потом по Производителю).

Результат, которого хотим добиться, выглядит примерно так:

Разумеется, если смотреть прайс только на компьютере, то можно добавить фильтры и будет гораздо удобнее искать нужный товар. Однако мы хотим научится кодить и задача вполне подходящая, не так ли?

Кодим

Для начала требуется создать кнопку, при нажатии на которую будет вызываться наша програма. Кнопки находятся в панели «Разработчик» и появляются по кнопке «Вставить». Вам нужен компонент формы «Кнопка». Нажали, поставили на любое место в листе. Далее, если не появилось окно назначения макроса, надо нажать правой кнопкой и выбрать пункт «Назначить макрос». Назовём его FormatPrice. Важно, чтобы перед именем макроса ничего не было — иначе он создастся в отдельном модуле, а не в пространстве имен книги. В этому случае вам будет недоступно быстрое обращение к выделенному листу. Нажимаем кнопку «Новый».

И вот мы в среде разработки VB. Также её можно вызвать из контекстного меню командой «Исходный текст»/«View code».

Перед вами окно с заглушкой процедуры. Можете его развернуть. Код должен выглядеть примерно так:

Sub FormatPrice()End Sub

Напишем Hello World:

Sub FormatPrice() MsgBox "Hello World!" End Sub

И запустим либо щелкнув по кнопке (предварительно сняв с неё выделение), либо клавишей F5 прямо из редактора.

Тут, пожалуй, следует отвлечься на небольшой ликбез по поводу синтаксиса VB. Кто его знает — может смело пропустить этот раздел до конца. Основное отличие Visual Basic от Pascal/C/Java в том, что команды разделяются не ;, а переносом строки или двоеточием (:), если очень хочется написать несколько команд в одну строку. Чтобы понять основные правила синтаксиса, приведу абстрактный код.

Примеры синтаксиса

' Процедура. Ничего не возвращает ' Перегрузка в VBA отсутствует Sub foo(a As String, b As String) ' Exit Sub ' Это значит "выйти из процедуры" MsgBox a + ";" + b End Sub' Функция. Вовращает Integer Function LengthSqr(x As Integer, y As Integer) As Integer ' Exit Function LengthSqr = x * x + y * y End FunctionSub FormatPrice() Dim s1 As String, s2 As String s1 = "str1" s2 = "str2" If s1 <> s2 Then foo "123", "456" ' Скобки при вызове процедур запрещены End IfDim res As sTRING ' Регистр в VB не важен. Впрочем, редактор Вас поправит Dim i As Integer ' Цикл всегда состоит из нескольких строк For i = 1 To 10 res = res + CStr(i) ' Конвертация чего угодно в String If i = 5 Then Exit For Next iDim x As Double x = Val("1.234") ' Парсинг чисел x = x + 10 MsgBox xOn Error Resume Next ' Обработка ошибок - игнорировать все ошибки x = 5 / 0 MsgBox xOn Error GoTo Err ' При ошибке перейти к метке Err x = 5 / 0 MsgBox "OK!" GoTo ne





  


                       
  




Err:

    MsgBox 
"Err!"
ne:

On Error GoTo 0 ' Отключаем обработку ошибок ' Циклы бывает, какие захотите Do While True Exit DoLoop 'While True Do 'Until False Exit Do Loop Until False ' А вот при вызове функций, от которых хотим получить значение, скобки нужны. ' Val также умеет возвращать Integer Select Case LengthSqr(Len("abc"), Val("4")) Case 24 MsgBox "0" Case 25 MsgBox "1" Case 26 MsgBox "2" End Select' Двухмерный массив. ' Можно также менять размеры командой ReDim (Preserve) - см. google Dim arr(1 to 10, 5 to 6) As Integer arr(1, 6) = 8Dim coll As New Collection Dim coll2 As Collection coll.Add "item", "key" Set coll2 = coll ' Все присваивания объектов должны производится командой Set MsgBox coll2("key") Set coll2 = New Collection MsgBox coll2.Count End Sub

Грабли-1. При копировании кода из IDE (в английском Excel) есь текст конвертируется в 1252 Latin-1. Поэтому, если хотите сохранить русские комментарии — надо сохранить крокозябры как Latin-1, а потом открыть в 1251.

Грабли-2. Т.к. VB позволяет использовать необъявленные переменные, я всегда в начале кода (перед всеми процедурами) ставлю строчку Option Explicit. Эта директива запрещает интерпретатору заводить переменные самостоятельно.

Грабли-3. Глобальные переменные можно объявлять только до первой функции/процедуры. Локальные — в любом месте процедуры/функции.

Еще немного дополнительных функций, которые могут пригодится: InPos, Mid, Trim, LBound, UBound. Также ответы на все вопросы по поводу работы функций/их параметров можно получить в MSDN.

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

Кодим много и под Excel

В этой части мы уже начнём кодить нечто, что умеет работать с нашими листами в Excel. Для начала создадим отдельный лист с именем result (лист с данными назовём data). Теперь, наверное, нужно этот лист очистить от того, что на нём есть. Также мы «выделим» лист с данными, чтобы каждый раз не писать длинное обращение к массиву с листами.

Sub FormatPrice() Sheets("result").Cells.Clear Sheets("data").Activate End Sub

Работа с диапазонами ячеек

Вся работа в Excel VBA производится с диапазонами ячеек. Они создаются функцией Range и возвращают объект типа Range. У него есть всё необходимое для работы с данными и/или оформлением. Кстати сказать, свойство Cells листа — это тоже Range.

Примеры работы с Range

Sheets("result").Activate Dim r As Range Set r = Range("A1") r.Value = "123" Set r = Range("A3,A5") r.Font.Color = vbRed r.Value = "456" Set r = Range("A6:A7") r.Value = "=A1+A3"

Теперь давайте поймем алгоритм работы нашего кода. Итак, у каждой строчки листа data, начиная со второй, есть некоторые данные, которые нас не интересуют (ID, название и цена) и есть две вложенные группы, к которым она принадлежит (тип и производитель). Более того, эти строки отсортированы. Пока мы забудем про пропуски перед началом новой группы — так будет проще. Я предлагаю такой алгоритм:

Считали группы из очередной строки.
Пробегаемся по всем группам в порядке приоритета (вначале более крупные)
1. Если текущая группа не совпадает, вызываем процедуру AddGroup(i, name), где i — номер группы (от номера текущей до максимума), name — её имя. Несколько вызовов необходимы, чтобы создать не только наш заголовок, но и всё более мелкие.
После отрисовки всех необходимых заголовков делаем еще одну строку и заполняем её данными.

Для упрощения работы рекомендую определить следующие функции-сокращения:

Function GetCol(Col As Integer) As String GetCol = Chr(Asc("A") + Col) End FunctionFunction GetCellS(Sheet As String, Col As Integer, Row As Integer) As Range Set GetCellS = Sheets(Sheet).Range(GetCol(Col) + CStr(Row)) End FunctionFunction GetCell(Col As Integer, Row As Integer) As Range Set GetCell = Range(GetCol(Col) + CStr(Row)) End Function

Далее определим глобальную переменную «текущая строчка»: Dim CurRow As Integer. В начале процедуры её следует сделать равной единице. Еще нам потребуется переменная-«текущая строка в data», массив с именами групп текущей предыдущей строк. Потом можно написать цикл «пока первая ячейка в строке непуста».

Глобальные переменные

Option Explicit ' про эту строчку я уже рассказывал Dim CurRow As Integer Const GroupsCount As Integer = 2 Const DataCount As Integer = 3

FormatPrice

Sub FormatPrice() Dim I As Integer ' строка в data CurRow = 1 Dim Groups(1 To GroupsCount) As String Dim PrGroups(1 To GroupsCount) As String


    Sheets(

"data").Activate I = 2 Do While True If GetCell(0, I).Value = "" Then Exit Do ' ... I = I + 1 Loop End Sub

Теперь надо заполнить массив Groups:

На месте многоточия

Dim I2 As Integer For I2 = 1 To GroupsCount Groups(I2) = GetCell(I2, I) Next I2 ' ... For I2 = 1 To GroupsCount ' VB не умеет копировать массивы PrGroups(I2) = Groups(I2) Next I2 I = I + 1

И создать заголовки:

На месте многоточия в предыдущем куске

For I2 = 1 To GroupsCount If Groups(I2) <> PrGroups(I2) Then Dim I3 As Integer For I3 = I2 To GroupsCount AddHeader I3, Groups(I3) Next I3 Exit For End If Next I2

Не забудем про процедуру AddHeader:

Перед FormatPrice

Sub AddHeader(Ty As Integer, Name As String) GetCellS("result", 1, CurRow).Value = Name CurRow = CurRow + 1 End Sub

Теперь надо перенести всякую информацию в result

For I2 = 0 To DataCount - 1 GetCellS("result", I2, CurRow).Value = GetCell(I2, I) Next I2

Подогнать столбцы по ширине и выбрать лист result для показа результата

После цикла в конце FormatPrice

Sheets("Result").Activate Columns.AutoFit

Всё. Можно любоваться первой версией.

Некрасиво, но похоже. Давайте разбираться с форматированием. Сначала изменим процедуру AddHeader:

Sub AddHeader(Ty As Integer, Name As String) Sheets("result").Range("A" + CStr(CurRow) + ":C" + CStr(CurRow)).Merge ' Чтобы не заводить переменную и не писать каждый раз длинный вызов ' можно воспользоваться блоком With With GetCellS("result", 0, CurRow) .Value = Name .Font.Italic = True .Font.Name = "Cambria" Select Case Ty Case 1 ' Тип .Font.Bold = True .Font.Size = 16 Case 2 ' Производитель .Font.Size = 12 End Select .HorizontalAlignment = xlCenter End With CurRow = CurRow + 1 End Sub

Уже лучше:

Осталось только сделать границы. Тут уже нам требуется работать со всеми объединёнными ячейками, иначе бордюр будет только у одной:

Поэтому чуть-чуть меняем код с добавлением стиля границ:

Sub AddHeader(Ty As Integer, Name As String) With Sheets("result").Range("A" + CStr(CurRow) + ":C" + CStr(CurRow)) .Merge .Value = Name .Font.Italic = True .Font.Name = "Cambria" .HorizontalAlignment = xlCenterSelect Case Ty Case 1 ' Тип .Font.Bold = True .Font.Size = 16 .Borders(xlTop).Weight = xlThick Case 2 ' Производитель .Font.Size = 12 .Borders(xlTop).Weight = xlMedium End Select .Borders(xlBottom).Weight = xlMedium ' По убыванию: xlThick, xlMedium, xlThin, xlHairline End With CurRow = CurRow + 1 End Sub

Осталось лишь добится пропусков перед началом новой группы. Это легко:

В начале FormatPrice

Dim I As Integer ' строка в data CurRow = 0 ' чтобы не было пропуска в самом начале Dim Groups(1 To GroupsCount) As String

В цикле расстановки заголовков

If Groups(I2) <> PrGroups(I2) Then CurRow = CurRow + 1 Dim I3 As Integer

В точности то, что и хотели.

Надеюсь, что эта статья помогла вам немного освоится с программированием для Excel на VBA. Домашнее задание — добавить заголовки «ID, Название, Цена» в результат. Подсказка: ~~CurRow = 0~~ CurRow = 1.

Файл можно скачать тут (min.us) или тут (Dropbox). Не забудьте разрешить исполнение макросов. ~~Если кто-нибудь подскажет человеческих файлохостинг, залью туда.~~

Спасибо за внимание.

Буду рад конструктивной критике в комментариях.

UPD: Перезалил пример на Dropbox и min.us.

UPD2: На самом деле, при вызове процедуры с одним параметром скобки можно поставить. Либо использовать конструкцию Call Foo(«bar», 1, 2, 3) — тут скобки нужны постоянно.

Источник