'Отключение отображения выполняемых действий

Application.ScreenUpdating = False

'Предотвращение появления предупреждающих сообщений

Application.DisplayAlerts = False

'Предотвращение появления предупреждения об обновлении связей данных

Application.AskToUpdateLinks = False

'Очистка буфера обмена

Application.CutCopyMode = False

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

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

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")

VK.Frame1.Controls("rBtn1")

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