MyTetra Share
Делитесь знаниями!
Полезные команды VBA
06.04.2018
11:19
Текстовые метки: vba
Раздел: VBA

Полезные команды VBA


Пополняемый список полезных отрывков кода 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


Источник>>

Полезно:

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования