Макросы VBA Excel — Страница 3
Макрос запрашивает строку для поиска, после чего ищет введенный текст в первом столбце листа, и подсвечивает результаты поиска.
При запуске макроса появляется диалоговое окно (InputBox), позволяющее задать текст для поиска.
Макрос подсвечивает красным цветом внутри ячейки текст, совпадающий с искомым
(+ выделяет найденное полужирным начертанием)
Перед началом поиска, цвет всех ячеек первого столбца сбрасывается (на черный)
Как известно, в последних версиях Excel легко выделить дубликаты цветом, - для этого есть специальная опция в «условном форматировании».
Достаточно выделить диапазон, задать цвет заливки, - и все повторяющиеся (или, наоборот, уникальные) значения будут выделены.
Но иногда требуется, чтобы различные повторяющиеся значения были выделены РАЗНЫМИ ЦВЕТАМИ.
В этом случае, без макросов не обойтись.
Ниже приведён макрос, который как раз и решает эту задачу
(достаточно выделить диапазон ячеек, запустить макрос, - и повторяющиеся непустые ячейки получат одинаковый цвет заливки)
Функция UniqueValuesFromArray позволяет найти в указанном столбце двумерного массива все уникальные значения, и получить новый массив, содержащий все найденные уникальные значения.
Это может пригодиться, если надо, к примеру, заполнить ComboBox на форме возможными вариантами значений из базы данных:
Private Sub UserForm_Initialize()
On Error Resume Next: arr = PriceRange.Value
If Err Then MsgBox "Нет строк для обработки!", vbCritical, "Ошибка": End
' заполняем комбобокс уникальными значениями из 6-го столбца таблицы
Me.ComboBox_Source.List = UniqueValuesFromArray(arr, 6)
End Sub
Данная функция возвращает исходный текст web-страницы:
Function GetHTTPResponse(ByVal sURL As String) As String
On Error Resume Next
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
With oXMLHTTP
.Open "GET", sURL, False
' раскомментируйте следующие строки и подставьте верные IP, логин и пароль
' если вы сидите за proxy
' .setProxy 2, "192.168.100.1:3128"
' .setProxyCredentials "user", "password"
.send
GetHTTPResponse = .responseText
End With
Set oXMLHTTP = Nothing
End Function
Прикреплённая к статье надстройка содержит модуль, который может создавать панель инструментов любой сложности при запуске файла.
В данной статье показаны 2 способа быстрого поиска значений в двумерных массивах.
Поскольку искомое значение может встретиться в нескольких строках обрабатываемого двумерного массива,
оба способа получают на выходе отфильтрованный двумерный массив.
Способы формирования отфильтрованных массивов - разные:
первый способ использует функцию ArrAutofilterEx
второй способ - функцию ArraySearchResults
Основные отличия и особенности этих 2 способов поиска:
-
ArrAutofilterEx позволяет задавать несколько критериев поиска (фильтрации)
-
ArrAutofilterEx ищет вхождение искомого текста в значения заданных столбцов (неточное совпадение)
-
ArrAutofilterEx при каждом вызове заново в цикле перебирает все элементы массива,
соответственно, при поиске 10 значений время работы кода увеличивается в 10 раз
-
ArraySearchResults позволяет использовать фильтрацию массива только по одному столбцу
-
ArraySearchResults ищет совпадение искомого текста со значением столбца (точное совпадение)
-
ArraySearchResults производит поиск в заранее сформированной текстовой строке
Таким образом, перебираются все ячейки массива в цикле только один раз, и поиск 100 значений в массиве займёт ненамного больше времени, чем поиск 1 значения.
Макрос предназначен для загрузки изображений (или любых других файлов) из интернета, и сохранения скачанных файлов в одну папку.
Исходные данные для работы макроса:
таблица, в которой содержатся по меньшей мере 2 столбца - один с гиперссылками, второй - с именами файлов.
Особенности макроса:
-
создаваемым файлам присваиваются имена из выбранного столбца листа Excel
-
макрос корректно работает со ссылками, содержащими символы кириллицы
-
автоматическое добавление расширения для скачиваемых файлов (если имя файла из ячейки его не содержит)
Настройки макроса легко выполнить, изменив в коде значения констант:
Const НазваниеПапкиДляФайлов$ = "Фотографии" ' так будет называться создаваемая папка
Const НомерСтолбцаСГиперссылками = 6 ' из этого столбца макрос берет гиперссылки для загрузки файлов
Const НомерСтолбцаСИменамиФайлов = 4 ' из этого столбца макрос берет имена для создаваемых файлов
Const НомерПервойСтрокиСДанными = 2 ' с какой строки листа начинаем обрабатывать данные
Const РасширениеФайлов$ = ".jpg" ' этот текст добавляется справа к именам создаваемых файловСмотрите также аналогичный (более сложный) макрос загрузки изображений
Как известно, VBA-функция MkDir может создать только папку в существующем каталоге (папке).
Например, код MkDir "C:\Папка\" отработает корректно в любом случае (создаст указанную папку),
а код MkDir "C:\Папка\Подпапка\Каталог\" выдаст ошибку Run-time error '76': Path not found
(потому что невозможно создать каталог Подпапка в несуществующем ещё каталоге Папка)
Можно, конечно, использовать несколько функций MkDir подряд - но это усложняет код.
Самый простой способ решения проблемы - использование WinAPI-функции SHCreateDirectoryEx, которая может создать все нужные папки и подпапки за один запуск.
Надстройка позволяет экспортировать все изображения с листа Excel в графические файлы.
Макрос для исправление повреждённых гиперссылок во всей книге:
Sub ЗаменаИспорченныхГиперссылок()
On Error Resume Next
Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
' часть гиперссылки, подлежащая замене
oldString = "C:\Documents and settings\Бухгалтер\Application data"
' на что заменяем
newString = "\\адрес_сервера"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
If hl.Address Like oldString & "*" Then
hl.Address = Replace(hl.Address, oldString, newString)
End If
Next
Next sh
End Sub Макрос может быть полезен для замены абсолютных гиперссылок на относительные, а также помогает вернуть работоспособность ссылок после случайного сохранения файла Excel в другой папке (на другом диске).
Если нужно заменить несколько вариантов неверных ссылок, код будет таким:
Sub ЗаменаИспорченныхГиперссылок_2()
On Error Resume Next
Dim hl As Hyperlink, newString$, sh As Worksheet
' часть гиперссылки, подлежащая замене
oldString1 = "C:\Documents and settings\Бухгалтер\1"
oldString2 = "C:\Documents and settings\Бухгалтер\2"
' на что заменяем
newString = "\\адрес_сервера"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
If hl.Address Like oldString1 & "*" Then hl.Address = Replace(hl.Address, oldString1, newString)
If hl.Address Like oldString2 & "*" Then hl.Address = Replace(hl.Address, oldString2, newString)
Next
Next sh
End SubРасширенная версия этого макроса учитывает, что слеш в ссылках может быть как прямым, так и обратным, а также выводит информацию о количестве произведённых замен, и список ссылок из файла, которые не были обработаны (к которым замены не были применены)
Sub ЗаменаИспорченныхГиперссылок2()
On Error Resume Next
Dim hl As Hyperlink, oldString$, newString$, sh As Worksheet, n&, msg$, coll As New Collection, Item
' часть гиперссылки, подлежащая замене
oldString = "../../AppData/Roaming/Microsoft/Excel/"
' на что заменяем
newString = "C:\Users\Admin\Desktop\ОТЧЁТЫ ВСЕ\"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
' Debug.Print hl.Address
If (hl.Address Like oldString & "*") Or (hl.Address Like Replace(oldString, "/", "\") & "*") Then
hl.Address = Replace(hl.Address, oldString, newString, , , vbTextCompare)
hl.Address = Replace(hl.Address, Replace(oldString, "/", "\"), newString, , , vbTextCompare)
n = n + 1
Else
If InStr(1, hl.Address, "mailto", vbTextCompare) = 0 Then coll.Add hl.Address, UCase(hl.Address)
End If
Next
Next sh
For Each Item In coll
msg$ = msg$ & Item & vbNewLine
Next
MsgBox "Заменено гиперссылок: " & n & IIf(Len(msg$), vbNewLine & vbNewLine & _
"Также в файле найдены ссылки на:" & vbNewLine & msg$, ""), vbInformation
End Sub
|
|
