Vba excel автонумерация строк

© планеро.ru

Here is my code to add line numbers in the VBE IDE. It is an improvement of the solution provided here by Excel MVP mikerickson. I have worked on this, because in some rare cases I have already met, VBE can’t enter in debug mode, for example when you have a .ReplaceLine method in your code. Indeed, you can’t enter in debug mode once it has been executed, so Erl might be usefully for debug (instead of Debug.Print). I have added several feature such as:

• possibility to either add line numbers as labels: 10: Dim foo as bar or as single numbers seperated from code by a tab: 10 Dim foo as bar
• possibility to add line numbers to End of procedures statements, and to match the indent of the procedure declaration lines to its End statement line once numberered. Or not.
• possibility of add line numbers to empty lines or not
• [WIP] possibility to add line numbers to a specific procedure in a module
• [WIP] match all indentations of code lines with line numbers to match the indent of the last line indented. If last line is 200: End Sub, the line 30: With ActiveSheet will be re-indented as 30: ActiveSheet
• [WIP] add of a VBE IDE command to directly make the calls with the current module/proc as a parameter

Public Enum vbLineNumbers_LabelTypes
    vbLabelColon    ' 0
    vbLabelTab      ' 1
End Enum

Public Enum vbLineNumbers_ScopeToAddLineNumbersTo
    vbScopeAllProc  ' 1
    vbScopeThisProc ' 2
End Enum

Sub AddLineNumbers(ByVal wbName As String, _
                   ByVal vbCompName As String, _
                   ByVal LabelType As vbLineNumbers_LabelTypes, _
                   ByVal AddLineNumbersToEmptyLines As Boolean, _
                   ByVal AddLineNumbersToEndOfProc As Boolean, _
                   ByVal Scope As vbLineNumbers_ScopeToAddLineNumbersTo, _
                   Optional ByVal thisProcName As String)

' USAGE RULES
' DO NOT MIX LABEL TYPES FOR LINE NUMBERS! IF ADDING LINE NUMBERS AS COLON TYPE, ANY LINE NUMBERS AS VBTAB TYPE MUST BE REMOVE BEFORE, AND RECIPROCALLY ADDING LINE NUMBERS AS VBTAB TYPE

    Dim i As Long
    Dim j As Long
    Dim procName As String
    Dim startOfProcedure As Long
    Dim lengthOfProcedure As Long
    Dim endOfProcedure As Long
    Dim strLine As String

    With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
        .CodePane.Window.Visible = False

If Scope = vbScopeAllProc Then

        For i = 1 To .CountOfLines

            strLine = .Lines(i, 1)
            procName = .ProcOfLine(i, vbext_pk_Proc) ' Type d'argument ByRef incompatible ~~> Requires VBIDE library as a Reference for the VBA Project

            If procName <> vbNullString Then
                startOfProcedure = .ProcStartLine(procName, vbext_pk_Proc)
                bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
                countOfProcedure = .ProcCountLines(procName, vbext_pk_Proc)

                prelinesOfProcedure = bodyOfProcedure - startOfProcedure
                'postlineOfProcedure = ??? not directly available since endOfProcedure is itself not directly available.

                lengthOfProcedure = countOfProcedure - prelinesOfProcedure ' includes postlinesOfProcedure !
                'endOfProcedure = ??? not directly available, each line of the proc must be tested until the End statement is reached. See below.

                If endOfProcedure <> 0 And startOfProcedure < endOfProcedure And i > endOfProcedure Then
                    GoTo NextLine
                End If

                If i = bodyOfProcedure Then InProcBodyLines = True

                If bodyOfProcedure < i And i < startOfProcedure + countOfProcedure Then
                    If Not (.Lines(i - 1, 1) Like "* _") Then

                        InProcBodyLines = False

                        PreviousIndentAdded = 0

                        If Trim(strLine) = "" And Not AddLineNumbersToEmptyLines Then GoTo NextLine

                        If IsProcEndLine(wbName, vbCompName, i) Then
                            endOfProcedure = i
                            If AddLineNumbersToEndOfProc Then
                                Call IndentProcBodyLinesAsProcEndLine(wbName, vbCompName, LabelType, endOfProcedure)
                            Else
                                GoTo NextLine
                            End If
                        End If

                        If LabelType = vbLabelColon Then
                            If HasLabel(strLine, vbLabelColon) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelColon)
                            If Not HasLabel(strLine, vbLabelColon) Then
                                temp_strLine = strLine
                                .ReplaceLine i, CStr(i) & ":" & strLine
                                new_strLine = .Lines(i, 1)
                                If Len(new_strLine) = Len(CStr(i) & ":" & temp_strLine) Then
                                    PreviousIndentAdded = Len(CStr(i) & ":")
                                Else
                                    PreviousIndentAdded = Len(CStr(i) & ": ")
                                End If
                            End If
                        ElseIf LabelType = vbLabelTab Then
                            If Not HasLabel(strLine, vbLabelTab) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelTab)
                            If Not HasLabel(strLine, vbLabelColon) Then
                                temp_strLine = strLine
                                .ReplaceLine i, CStr(i) & vbTab & strLine
                                PreviousIndentAdded = Len(strLine) - Len(temp_strLine)
                            End If
                        End If

                    Else
                        If Not InProcBodyLines Then
                            If LabelType = vbLabelColon Then
                                .ReplaceLine i, Space(PreviousIndentAdded) & strLine
                            ElseIf LabelType = vbLabelTab Then
                                .ReplaceLine i, Space(4) & strLine
                            End If
                        Else
                        End If
                    End If

                End If

            End If

NextLine:
        Next i

ElseIf AddLineNumbersToEmptyLines And Scope = vbScopeThisProc Then

End If

        .CodePane.Window.Visible = True
    End With

End Sub

Function IsProcEndLine(ByVal wbName As String, _
                   ByVal vbCompName As String, _
                   ByVal Line As Long) As Boolean

With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
    If Trim(.Lines(Line, 1)) Like "End Sub*" _
    Or Trim(.Lines(Line, 1)) Like "End Function*" _
    Or Trim(.Lines(Line, 1)) Like "End Property*" _
    Then IsProcEndLine = True
End With

End Function

Sub IndentProcBodyLinesAsProcEndLine(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes, ByVal ProcEndLine As Long)
    Dim procName As String
    Dim startOfProcedure As Long
    Dim endOfProcedure As Long

    With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule

        procName = .ProcOfLine(ProcEndLine, vbext_pk_Proc)
        bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
        endOfProcedure = ProcEndLine
        strEnd = .Lines(endOfProcedure, 1)

        j = bodyOfProcedure
        Do Until Not .Lines(j - 1, 1) Like "* _" And j <> bodyOfProcedure

            strLine = .Lines(j, 1)

            If LabelType = vbLabelColon Then
                If Mid(strEnd, Len(CStr(endOfProcedure)) + 1 + 1 + 1, 1) = " " Then
                    .ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 1) & strLine
                Else
                    .ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 2) & strLine
                End If
            ElseIf LabelType = vbLabelTab Then
                If endOfProcedure < 1000 Then
                    .ReplaceLine j, Space(4) & strLine
                Else
                    Debug.Print "This tool is limited to 999 lines of code to work properly."
                End If
            End If

            j = j + 1
        Loop

    End With
End Sub

Sub RemoveLineNumbers(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes)
    Dim i As Long
    With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule

        For i = 1 To .CountOfLines

            procName = .ProcOfLine(i, vbext_pk_Proc)

            If procName <> vbNullString Then

                If i = .ProcBodyLine(procName, vbext_pk_Proc) Then InProcBodyLines = True

                LenghtBefore = Len(.Lines(i, 1))
                If Not .Lines(i - 1, 1) Like "* _" Then
                    InProcBodyLines = False
                    .ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1), LabelType)
                Else
                    If IsInProcBodyLines Then
                        ' do nothing
                    Else
                        .ReplaceLine i, Mid(.Lines(i, 1), RemovedChars_previous_i + 1)
                    End If
                End If
                LenghtAfter = Len(.Lines(i, 1))

                LengthBefore_previous_i = LenghtBefore
                LenghtAfter_previous_i = LenghtAfter
                RemovedChars_previous_i = LengthBefore_previous_i - LenghtAfter_previous_i

                If Trim(.Lines(i, 1)) Like "End Sub*" Or Trim(.Lines(i, 1)) Like "End Function" Or Trim(.Lines(i, 1)) Like "End Property" Then

                    LenOfRemovedLeadingCharacters = LenghtBefore - LenghtAfter

                    procName = .ProcOfLine(i, vbext_pk_Proc)
                    bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)

                    j = bodyOfProcedure
                    strLineBodyOfProc = .Lines(bodyOfProcedure, 1)
                    Do Until Not strLineBodyOfProc Like "* _"
                        j = j + 1
                        strLineBodyOfProc = .Lines(j, 1)
                    Loop
                    LastLineBodyOfProc = j
                    strLastLineBodyOfProc = strLineBodyOfProc

                    strLineEndOfProc = .Lines(i, 1)
                    For k = bodyOfProcedure To j
                        .ReplaceLine k, Mid(.Lines(k, 1), 1 + LenOfRemovedLeadingCharacters)
                    Next k

                    i = i + (j - bodyOfProcedure)
                    GoTo NextLine

                End If
            Else
            ' GoTo NextLine
            End If
NextLine:
        Next i
    End With
End Sub

Function RemoveOneLineNumber(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes)
    RemoveOneLineNumber = aString
    If LabelType = vbLabelColon Then
        If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Then
            RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare))
            If Left(RemoveOneLineNumber, 2) Like " [! ]*" Then RemoveOneLineNumber = Mid(RemoveOneLineNumber, 2)
        End If
    ElseIf LabelType = vbLabelTab Then
        If aString Like "#   *" Or aString Like "##  *" Or aString Like "### *" Then RemoveOneLineNumber = Mid(aString, 5)
        If aString Like "#" Or aString Like "##" Or aString Like "###" Then RemoveOneLineNumber = ""
    End If
End Function

Function HasLabel(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes) As Boolean
    If LabelType = vbLabelColon Then HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ")
    If LabelType = vbLabelTab Then
        HasLabel = Mid(aString, 1, 4) Like "#   " Or Mid(aString, 1, 4) Like "##  " Or Mid(aString, 1, 4) Like "### "
    End If
End Function

Function RemoveLeadingSpaces(ByVal aString As String) As String
    Do Until Left(aString, 1) <> " "
        aString = Mid(aString, 2)
    Loop
    RemoveLeadingSpaces = aString
End Function

Function WhatIsLineIndent(ByVal aString As String) As String
    i = 1
    Do Until Mid(aString, i, 1) <> " "
        i = i + 1
    Loop
    WhatIsLineIndent = i
End Function

Function HowManyLeadingSpaces(ByVal aString As String) As String
    HowManyLeadingSpaces = WhatIsLineIndent(aString) - 1
End Function

You can make calls like this :

Sub AddLineNumbers_vbLabelColon()
    AddLineNumbers wbName:="EvaluateCall.xlsm", vbCompName:="ModLineNumbers_testDest", LabelType:=vbLabelColon, AddLineNumbersToEmptyLines:=True, AddLineNumbersToEndOfProc:=True, Scope:=vbScopeAllProc
End Sub

Sub AddLineNumbers_vbLabelTab()
    AddLineNumbers wbName:="EvaluateCall.xlsm", vbCompName:="ModLineNumbers_testDest", LabelType:=vbLabelTab, AddLineNumbersToEmptyLines:=True, AddLineNumbersToEndOfProc:=True, Scope:=vbScopeAllProc
End Sub

Sub RemoveLineNumbers_vbLabelColon()
    RemoveLineNumbers wbName:="EvaluateCall.xlsm", vbCompName:="ModLineNumbers_testDest", LabelType:=vbLabelColon
End Sub

Sub RemoveLineNumbers_vbLabelTab()
    RemoveLineNumbers wbName:="EvaluateCall.xlsm", vbCompName:="ModLineNumbers_testDest", LabelType:=vbLabelTab
End Sub

And as a reminder, here as some compile rules about about line numbers:

• not allowed before a Sub/Function declaration statement
• not allowed outside of a proc
• not allowed on a line following a line continuation character «_» (underscore)
• not allowed to have more than one label/line number per code line ~~> Existing labels other than line numbers must be tested otherwise a compile error will occur trying to force a line number.
• not allowed to use characters that already have a special VBA meaning ~~> Allowed characters are [a-Z], [0-9], é, è, ô, ù, €, £, § and even «:» alone !
• compiler will trim any space before a label ~~> So if there is a label, the first char of the line is the first char of the label, it cannot be a space.
• appending a line number with a colon will result in having a space inserted between the «:» and the fist next char if there is none
• when appending a line number with a tab/space, there must be at least one space between the last digit and the first next char, compiler won’t add it as it does for a label with a colon separator
• the .ReplaceLine method will overide the compile rules without displaying any compile error as it does in design mode when selecting a new line or when manually relaunching compilation
• the compiler is ‘quicker than the VBA environment/system’: for example, just after a line number with colon and without any space has been inserted with .ReplaceLine, if the .Lines property is called to get the new string, the space (between the colon character and the first character of the string) is already appended in that string !
• it is not possible to enter debug mode after a .ReplaceLine has been called (from within or outside the module it is editting), not till the code is running, and execution reset.

Последнее время на работе занималась приведением excel-файлов к виду, при котором пользователь может допустить наименьшее количество ошибок при заполнении. До этого первый и последний раз я сталкивалась с visual basic в школе, причем не применительно к Ms Excel, поэтому потребовалось некоторое время на то, чтобы понять, как делать простые и, и тем более не очень, вещи. Эта статейка может помочь людям, оказавшимся в похожей ситуации, быстрее войти в курс дела. Демо-экселька прилагается.

Основы

Самый первый вопрос, который у меня возник, после того как вкладка «Разработчик» была добавлена (подробнее тут, например) и открыт встроенный vba-редактор, это куда собственно писать код. По умолчанию в книге есть модули страниц, модуль книги и один общий модуль. Существуют также модули формы и классов, но сейчас речь не о них. Все вполне логично: обработку событий на объекты страницы пишем в соответствующий лист страницы, обработку событий для книги — в модуль книги, а общие функции для всех листов — в общий модуль. При этом имеет смысл создать еще модули для отделения функционала по смыслу.

Также сразу возникает вопрос, а как элементарно обратиться к ячейке, найти ее значение и перезаписать его. Очень просто:

‘ в ячейку А1 пишем «add note» + значение ячейки B1
Cells(1,1).Value = «add note » & Cells(1,2).Value

For Each oCell In Range(«A1:A10»).Cells
     ‘обработка 
     oCell.Value = oCell.Row ‘ присвоили номер строки   
Next 

Моим следующим вопросом было каким образом вернуть значение из функции. В vba есть два типа функций: sub и function. Разница в том, что function как раз и умеет возвращать значение, для этого в коде функции надо написать ИмяФункции = возвращаемое_значение:

Public Function insertRow()
    Dim position As Integer
    ‘…
    insertRow = position ‘возвращаемое значение

End Function

После написания нескольких функций во встроенном редакторе, меня нешуточно заинтересовало, как перенести строку кода на следующую физическую строку. Если посреди строки кода нажать enter, кроме ошибки мы ничего не добьемся. Оказывается, надо использовать «_»:

If ActiveSheet.Index = 1 _
   Or ActiveSheet.Index = 4 Then
        ‘ действия
End If

Нарочно и не придумаешь.

Помимо массивов, в VBA следует обратить внимание на коллекции. Работать с ними просто:

Dim сoll As New Collection
сoll.Add («элемент1»)‘добавляем элемент
сoll.Add («элемент2»)‘размер увеличивается динамически
‘ по умолчанию индекс начинается с 1, можно изменить
MsgBox (сoll.Item(1)) ‘элемент1
сoll.Remove (1) ‘ удаляем первый элемент
MsgBox (сoll.Count)‘выводим размер коллекции

Чтобы когда мы творим беспредел с нашим excel-файликом посредством vba, он предательски не корчился и напоказ не дергал строками и столбцами перед пользователем (например, при удалении и скрытии интервалов), можно отключать прорисовку:

Application.ScreenUpdating = False ‘ значение True включает

Автоматическая нумерация строк таблицы

Одной из первых моих мелких подзадач стала нумерация строк таблицы. Можно, конечно, при добавлении строки вставлять номер функцией, но хотелось по возможности чтобы это происходило само собой. Как выяснилось, нумеровать ячейки можно формулой =СТРОКА(ячейка), которая возвращает номер строки ячейки-параметра. Например, формула =СТРОКА(А1), вставленная в произвольную ячейку, выведет 1, строка =СТРОКА(А3) — цифру 3. 

Таким образом, при копировании формулы в следующую строку нумерация таблицы продолжится:

‘проставляем формулу нумерации

Range(«A7»).FormulaR1C1 = Range(«A6»).FormulaR1C1 

Если нужно также копировать формат ячейки, используется метод AutoFill.

Тут может возникнуть одна неприятность. Пусть наша последовательность ячеек с формулами начинается  не с первой строки, а например, с третьей. Тогда в третьей строке будет формула =Строка(А1), во второй — =Строка(А2), в 10 — =Строка(А10) и т.д. Тогда при удалении строки 6 формула в теперешней строке 9 выдаст ошибку «неверная ссылка». 

Это потому, что формула в строке А9 крайне смущена тем, что ссылается на удаленную ячейку. Поэтому если строки в таблице буду удаляться и добавляться, лучше сделать ссылку на ячейки другой страницы (=СТРОКА(Лист2!А1)).

Кнопки вставки и удаления строк

Само по себе добавление и удаление по имени кнопки сложности не представляет:

Private Sub InsertButton1_Click(position as Integer)
   ‘вставка строки перед строкой с номером position
   Rows(position).Insert
End Sub


Private Sub DeleteButton1_Click()
   Dim position as Integer
   ‘ ищем номер строки кнопки удаления
   position = _            ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row  
   ‘ удаление кнопки
   ActiveSheet.Shapes(Application.Caller).Delete 
   ‘ удаление строки с номером position
   Rows(position).Delete
End Sub

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

Но вот проблемка, которую по внимательности можно сразу и не разглядеть. Вот мы добавили некоторое количество строк с кнопками в обеих таблицах, потом поудаляли и снова добавили. Возникает ситуация, при которой у нас на листе появляются кнопки с одинаковым именем (т.к. они создавались на строке с одним и тем же номером). В связи с этим возникают проблемы при их удалении (удаляется последняя кнопка из всех с одинаковым именем).

Нам нужен уникальный идентификатор. Чтобы не заниматься генерацией уникальных хэшей, можно, например, использовать имяКнопки_номерСтроки_текущаяДата. 

newButtonId = «delButton» & insertedRowNumber & Now()

Проверка листа на правильное заполнение 

Но проблема вот в чем — если мы берем colorIndex или color ячейки, нам возвращается исходный цвет, не тот, на который он изменился при помощи условного форматирования.

Прилагаю демо-эксельку. Тестировалась в русифицированном MS Excel 2007.