Пополняемый список полезных отрывков кода VBA для выполнения часто востребованных действий в MS Excel.
Служебные команды для ускорения скорости выполнения макроса:
'Отключение отображения выполняемых действий
Application.ScreenUpdating = False
'Предотвращение появления предупреждающих сообщений
Application.DisplayAlerts = False
'Предотвращение появления предупреждения об обновлении связей данных
Application.AskToUpdateLinks = False
'Очистка буфера обмена
Application.CutCopyMode = False
Проверка имени пользователя, запустившего макрос:
Чтобы проверить, какой пользователь открыл книгу Excel можно использовать один из следующих вариантов:
If Application.UserName = "Имя_автора_документа" Then ...
If Environ("username") = "user" Then ...
Поиск последней строки таблицы:
Set myWSheet = ThisWorkbook.Sheets("Имя_листа")
With myWSheet
'Определение индекса последней строки таблицы
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Определение значения в ячейки последней строке столбца A
lastARow = .Range("A" & lastRow).Value
End With
Замена формулы на значение:
Selection.Value = Selection.Value
Добавление нового листа с именем после всех существующих:
Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "Имя_листа"
Как узнать последний день предыдущего месяца:
LastMonthDay = DateAdd("d", -1, DateSerial(Year(dtDate), Month(dtDate), 1))
Определение оставшихся дней месяца:
dToEndOfMonth = DateDiff("d", dFrom, DateAdd("d", -1, _
DateSerial(Year(dFrom), Month(dFrom) + 1, 1)))
Номер текущего дня в неделе (воскресенье — первый день):
DayOfWeek = DatePart("w", dToday)
Создание нового файла из текущего:
pathNewBook = "C:\Temp"
nameNewBook = "Имя_нового_файла.xls"
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=pathNewBook & nameNewBook
ActiveWorkbook.Close True
Сохранить текущий файл в формате CSV
Чтобы при сохранении файла в формате CSV, вместо запятых в качестве разделителя использовалась точка с запятой, следует использовать подобный код:
ActiveWorkbook.SaveAs FileName:="Name.csv", FileFormat:=xlCSV, _
CreateBackup:=False, Local:=True
ActiveWorkbook.Saved = True
ActiveWorkbook.Close True
Копирование данных из одного файла в другой:
wbPath = "C:\Temp\"
wbName = "Имя_файла_откуда_копируем.xls"
Workbooks.Open (wbPath & wbName)
Set WB = Workbooks(wbName)
WB.Sheets("Лист 1").Range("A1:С10").Copy
Sheet("Лист_в_текущем_файле").Range("A2").PasteSpecial xlPasteValues
Чтобы открыть файл только для чтения, следует использовать:
Workbooks.Open (Filename:=wbPath & wbName, ReadOnly:=True)
Предотвращение ошибки при неудачном поиске значения в таблице:
Set DateRowObj = WB.Sheets("Имя_листа").Range("A:A")._
Find(What:=dtToAsDate, LookIn:=xlFormulas)
If (DateRowObj Is Nothing) Then
WB.Close False
MsgBox "Данные не найдены."
Else
DateRow = DateRowObj.Row 'Номер строки с искомым значением
End If
Как получить имя активной книги Excel без его расширения (без .xls либо без .xlsx):
wbName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
Проверка существования файла:
fPath = "C:\Temp\"
fName = "Файл.txt"
If Dir(fPath & fName) = "" Then
MsgBox "Файл не найден:" & Chr(13) & fPath & fName
Exit Sub
End If
Кнопка, скрывающая/разворачивающая часть таблицы:
Private Sub tbVid_Click()
Application.ScreenUpdating = False
If tbVid Then
tbVid.Caption = "Скрыть"
ActiveSheet.Rows("2:29").Hidden = False
Else
tbVid.Caption = "Развернуть"
ActiveSheet.Rows("2:29").Hidden = True
End If
End Sub
Обновление сводной таблицы:
currPath = ThisWorkbook.Path
currWBName = ThisWorkbook.Name
ListName.PivotTables("СводнаяТаблица1").ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:=currPath & "[" & _
currWBName & "]Лист1!R1C1:R10C5")
Обращение к элементам Frame:
VK.Frame1.Controls("rBtn1")
Замена #ДЕЛ/0! в диапазоне:
Selection.Replace What:="#DIV/0!", Replacement:="", LookAt:=xlPart,_
SearchOrder:=xlByRows, MatchCase:=False,_
SearchFormat:=False, ReplaceFormat:=False
Количество строк в отфильтрованной таблице:
Sheet1.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
Быстро убрать лишние пробелы в диапазоне:
Selection.Value = Application.Trim(Selection.Value)
Программно снять защиту с листа:
Sheet1.Unprotect ('password')
Работа с диапазоном
Умножить диапазон на число:
ThisWorkbook.Sheets(1).Range("A1:A10") = _
ThisWorkbook.Sheets(1).Evaluate("A1:A10" & "*80")
Добавить ко всем значениям диапазона строку:
ThisWorkbook.Range("A1:A10").Value = _
Evaluate("=""" & addTxt & """ & " & ThisWorkbook.Range("A1:A10").Address)
Сцепление данных диапазона с текстовым значением без цикла>>
Сортировка выбранного столбца в сводной таблице
Col = Selection.Column 'Номер выбранного столбца
ColMax = ActiveSheet.PivotTables("СводнаяТаблица").PivotColumnAxis. _
PivotLines.Count
If Col - 1 <= ColMax And Col 1 Then
ActiveSheet.PivotTables("СводнаяТаблица").PivotFields("Label").AutoSort _
xlDescending, " ", ActiveSheet.PivotTables("СводнаяТаблица"). _
PivotColumnAxis.PivotLines(Col - 1), 1
End If
Счетчик времени выполнения процедуры
'Счётчик, ставится в начале процедуры
StartUpdDate = Now
'Сообщение, выводится в конце процедуры
MsgBox "Данные обновлены за " & Fix(1440 * (Now – StartUpdDate)) & " мин. " & 86400 * (Now – StartUpdDate) Mod 60 & " сек."
Функция транслитерации с русского на английский
Function Translit(Txt As String) As String
Txt = Txt
Rus = Array("ий", "ый", "ъе", "ъя", "ъю", _
"ъё", "ье", "ья", "ью", "ьё", "а", "б", "в", "г", _
"д", "е", "ё", "ж", "з", "и", "й", "к", "л", _
"м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", _
"ц", "ч", "ш", "щ", "ъ", "ы", "ь", "э", "ю", "я", _
"ИЙ", "ЫЙ", "ЪЕ", "ЪЯ", "ЪЮ", _
"ЪЁ", "ЬЕ", "ЬЯ", "ЬЮ", "ЬЁ", "А", "Б", "В", "Г", _
"Д", "Е", "Ё", "Ж", "З", "И", "Й", "К", "Л", _
"М", "Н", "О", "П", "Р", "С", "Т", "У", "Ф", "Х", _
"Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я", _
" ", "_", "?", _
"a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
"n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "«", "»")
Eng = Array("y", "y", "ye", "ya", "yu", _
"yo", "ye", "ya", "yu", "yo", "a", "b", "v", "g", _
"d", "e", "yo", "zh", "z", "i", "y", "k", "l", "m", _
"n", "o", "p", "r", "s", "t", "u", "f", "h", "ts", _
"ch", "sh", "sch", "", "y", "", "eh", "u", "ya", _
"Y", "Y", "Ye", "Ya", "Yu", _
"Yo", "Ye", "Ya", "Yu", "Yo", "A", "B", "V", "G", _
"D", "E", "Yo", "Zh", "Z", "I", "Y", "K", "L", "M", _
"N", "O", "P", "R", "S", "T", "U", "F", "H", "Ts", _
"Ch", "Sh", "Sch", "", "Y", "", "Eh", "U", "Ya", _
" ", "_", "?", _
"a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
"n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "", "")
For i = 1 To Len(Txt)
с = Mid(Txt, i, 1)
flag = 0
For J = 0 To 116
If Rus(J) = с Then
outchr = Eng(J)
flag = 1
Exit For
End If
Next J
If flag Then outstr = outstr & outchr Else outstr = outstr & с
Next i
Translit = outstr
End Function
Поиск файлов в папке
Dim strDirPath, strMaskSearch, strFileName as String
strDirPath = "C:/test/" 'Папка поиска
strMaskSearch = "*.xls*" 'Маска поиска
'Получаем первый файл соответствующий шаблону
strFileName = Dir(strDirPath & strMaskSearch)
Do While strFileName <> "" 'До тех пор пока файлы "не закончатся"
MsgBox strFileName
strFileName = Dir 'Следующий файл
Loop
Полезно:
- Excel Does Not Quit
- Как програмно ответить на всплывающее диалоговое окно «Эта книга содержит связи с другими источниками данных»
- VBA. Чтение и запись в Excel. Оптимизация.
- Типы данных и числовые форматы в Excel
- Как проверить открыт ли уже документ?