Макросы VBA Excel — Страница 17
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, можно воспользоваться функцией FillWorkbookProperties:
(в её работе используется коллекция BuiltinDocumentProperties)
Sub ПримерИспользования_FillWorkbookProperties()
FillWorkbookProperties ActiveWorkbook, "Название", "Тема", "Автор", "Ключевые Слова", , "EducatedFool", , "Компания"
End SubКод функции FillWorkbookProperties:
Данная функция позволяет запрашивать у пользователя цвет заливки.
Функция возвращает целое число - значение цвета в формате 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
Очень часто мне присылают для обработки файлы, в которых заголовки таблиц никак не отформатированы, что затрудняет работу с такими таблицами.
Поскольку выполнять вручную каждый раз одни и те же действия надоедает, бы написан этот простенький макрос.
Что он делает: (действия выполняются с выделенным диапазоном ячеек)
-
устанавливает выравнивание текста ячеек по центру
-
разрешает перенос текста ячеек по словам
-
закрашивает ячейки серым цветом
-
рисует рамку вокруг ячеек
-
закрепляет строку, расположенную непосредственно под выделенным заголовком
-
(чтобы заголовок таблицы не прокручивался при скроллинге)
К примеру, требуется преобразовать путь вида Z:\Папка\Разное\ (где Z - буква сетевого диска) в путь вида \\server\Files\Папка\Разное
Для этого можно использовать возможности объекта FileSystemObject:
Sub ПолучениеСетевогоПутиПапки()
ОбычныйПуть = "Z:\Папка\Разное\"
With CreateObject("Scripting.FileSystemObject").getfolder(ОбычныйПуть)
СетевойПуть = Replace(.Path, .Drive.Path, .Drive.ShareName)
End With
Debug.Print ОбычныйПуть, СетевойПуть
' СетевойПуть = \\server\Files\Папка\Разное
End Sub
Данная функция позволяет определить, содержатся ли в текстовой строке элементы массива:
Function LikeAnItemOfArray(ByVal txt$, ByVal arr) As Boolean
' возвращает TRUE, если в строке txt$ содержится хоть один элемент из массива arr
For Each Item In arr
pos = pos + InStr(1, txt$, Item, vbTextCompare)
Next
LikeAnItemOfArray = pos > 0
End Function
Этот код проверяет заданного доступность прокси сервера при помощи функции CheckProxyServer:
Sub ПримерПроверкиПроксиСервера()
myProxy$ = "212.45.5.172:3128"
If CheckProxyServer(myProxy$) Then
MsgBox "Прокси сервер с адресом " & myProxy$ & " доступен!", vbInformation
Else
MsgBox "Прокси сервер с адресом " & myProxy$ & " недоступен!", vbExclamation
End If
End SubПрокси-сервер (Proxy Server) позволяет скрыть ваш IP адрес, что позволяет вам выполнять запросы к одному и тому же серверу как-бы с разных компьютеров.
Это может быть полезно при выполнении многократных запросов к серверам типа Яндекс и Google,
которые блокируют автоматические запросы от программы по истечении некоторого времени.
Загрузить список прокси-серверов вам поможет этот код: http://excelvba.ru/code/ProxyServersList
Простой пример реализации гиперссылок и бегущей строки на форме средствами VBA.
Sub print_all_sub_and_function_names_of_current_project()
' пишет названия функций программы в файл c:\output.txt
Sub print_all_code_of_current_project()
' пишет весь код данной программы в файл c:\code.vb
|
|
