Open Notes

'Отключение отображения выполняемых действий
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