Макросы VBA Excel — Страница 33

Получение текста из диапазона ячеек

Function Range2TXT(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = vbTab, _
                   Optional ByVal RowsSeparator$ = vbNewLine) As String
    If ra.Cells.Count = 1 Then Range2TXT = ra.Value & RowsSeparator$: Exit Function
    If ra.Areas.Count > 1 Then
        Dim ar As Range
        For Each ar In ra.Areas
            Range2TXT = Range2TXT & Range2TXT(ar, ColumnsSeparator$, RowsSeparator$)
        Next ar
        Exit Function
    End If
    arr = ra.Value
    For i = LBound(arr, 1) To UBound(arr, 1)

Пользовательская функция суммы для ячеек с двумя значениями

Суммирование ячеек с двумя значениями - пользовательская функция

Данная функция предназначена для суммирования итогов и подитогов в таблице Excel, если в ячейках находятся сразу 2 значения
(к примеру, фактическое, и по плану), разделённые переводом строки (нажатием Alt + Enter)

При суммировании учитывается группировка строк.

Для суммирования несгруппированных строк используется функция СуммаПланФакт,
а для сгруппированных строк - функция СуммаПодитоговПланФакт

Примеры формул на листе Excel

=СуммаПодитоговПланФакт(D8:D9)
=СуммаПодитоговПланФакт(F8;H8;J8)
=СуммаПланФакт(D4:D10)

Заполнение пользовательских свойств книги Excel

Чтобы заполнить встроенные свойства (например, Тема, Руководитель, Организация, Автор, Категория, Ключевые слова, Название, Комментарий и т.д.) документа Excel, можно воспользоваться функцией FillWorkbookProperties:
(в её работе используется коллекция BuiltinDocumentProperties)

Sub ПримерИспользования_FillWorkbookProperties()
    FillWorkbookProperties ActiveWorkbook, "Название", "Тема", "Автор", "Ключевые Слова", , "EducatedFool", , "Компания"
End Sub

Код функции FillWorkbookProperties:

Макрос форматирования заголовка таблицы

Результат работы макроса форматирования заголовка таблицы

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

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

Что он делает: (действия выполняются с выделенным диапазоном ячеек)

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

Диалоговое окно выбора цвета (функция VBA для запроса цвета заливки)

Разное

Данная функция позволяет запрашивать у пользователя цвет заливки.

Функция возвращает целое число - значение цвета в формате RGB

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

Sub ОкраскаЯчейкиВВыбранныйЦвет()
    On Error Resume Next
    DefaultColor& = vbRed    ' цвет по-умолчанию
    NewColor& = PickNewColor(DefaultColor&)    ' выбираем новый цвет
    
    ActiveCell.Interior.Color = NewColor&    ' красим активную ячейку
End Sub

Код функции:

Function PickNewColor(Optional ByVal i_OldColor As Double = xlNone) As Double
    ' функция отображает диалоговое окно выбора цвета заливки
    ' и возвращает значение выбранного цвета
    On Error Resume Next:
    PickNewColor = i_OldColor
    Const BGColor As Long = 13160660, ColorIndexLast As Long = 32
    Dim myOrgColor As Double, myNewColor As Double, WB As Workbook
    Dim myRGB_R As Integer, myRGB_G As Integer, myRGB_B As Integer
    If ActiveWorkbook Is Nothing Then Application.ScreenUpdating = False: Set WB = Workbooks.Add
    myOrgColor = ActiveWorkbook.Colors(ColorIndexLast)    'save original palette color

    i_Color = IIf(i_OldColor = xlNone, BGColor, i_OldColor): myRGB_R = i_Color Mod 256
    i_Color = i_Color \ 256: myRGB_G = i_Color Mod 256
    i_Color = i_Color \ 256: myRGB_B = i_Color Mod 256
    ActiveWorkbook.ResetColors    'AppActivate Application.Name
    If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast, myRGB_R, myRGB_G, myRGB_B) Then
        PickNewColor = ActiveWorkbook.Colors(ColorIndexLast)
        ThisWorkbook.Colors(ColorIndexLast) = myOrgColor
    End If
    If Not WB Is Nothing Then WB.Close False: Application.ScreenUpdating = True
End Function