Skip to content

Instantly share code, notes, and snippets.

@ulvham

ulvham/1vba.vbs

Last active December 22, 2020 19:55
Show Gist options
  • Save ulvham/f368619e5aba09eabb56 to your computer and use it in GitHub Desktop.
Save ulvham/f368619e5aba09eabb56 to your computer and use it in GitHub Desktop.
Download ZIP
new_VBA
Raw
1vba.vbs
Sub run()
runremotescript "tachka", "domain\admin", "pass", "notepad"
End Sub
Sub runremotescript(compname, domainuser, pass, appname)
Dim objLocator, objWMIService, objScheduledJob
Dim tyear, datex, datey, martdate, octoberdate, i
Dim CurrTimePlusOneMin, RunTime, Res, intJobID
Set objLocator = CreateObject("wbemscripting.swbemlocator")
Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")
Set objService = objLocator.connectserver(compname, "\root\cimv2", domainuser, pass)
If Err.Number <> 0 Then
wscript.Echo Err.Number & ": " & Err.Description
wscript.Quit
End If
For Each objOS In objService.ExecQuery("SELECT * FROM Win32_OperatingSystem")
Exit For
Next
RunTime = objOS.LocalDateTime
RunTime = Left(RunTime, 4) & CStr(150 + Int(Mid(RunTime, 5, 10))) & Right(RunTime, 11)
Set objScheduledJob = objService.Get("Win32_ScheduledJob")
Res = objScheduledJob.Create(appname, RunTime, False, , 0, True, intJobID)
Set objScheduledJob = Nothing
Set objWMIService = Nothing
Set objLocator = Nothing
End Sub
'Set the following variables
MyDomain = "exmple.com"
MyDN = "DC=exmple,DC=com"
'Log File
OutputFile = "C:\AccOldPasswords.log"
'Do not modify below this line
Const SEC_IN_DAY = 86400
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const ADS_SCOPE_SUBTREE = 2
Set objDomainNT = GetObject("WinNT://" & MyDomain)
intMaxPwdAge = objDomainNT.Get("MaxPasswordAge") / SEC_IN_DAY
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCOmmand.ActiveConnection = objConnection
objCommand.CommandText = _
"Select Name, distinguishedName from 'LDAP://" & MyDN & _
"' Where objectClass='user' AND objectClass <> 'computer'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFile=fso.GetFile(OutputFile)
If Err.Number = 0 Then
Set AFileStream = FSO.OpenTextFile(OutputFile,2)
Else
Set AFileStream = FSO.CreateTextFile(OutputFile,2)
End If
AFileStream.WriteLine "Name" & chr(09) & "Password Status" & chr(09) & "Last Change" & _
chr(09) & "Expiration Date"
Do Until objRecordSet.EOF
If (InStr(objRecordSet.Fields("Name").Value, "SystemMailbox") = 1) Then
objRecordSet.MoveNext
Else
ldapStr = "LDAP://" & objRecordSet.Fields("distinguishedName").Value
Set objUserLDAP = GetObject(ldapStr)
intCurrentValue = objUserLDAP.Get("userAccountControl")
If intCurrentValue and ADS_UF_DONT_EXPIRE_PASSWD Then
'Do nothing
Else
dtmValue = objUserLDAP.PasswordLastChanged
intTimeInterval = int(now - dtmValue)
If intTimeInterval >= intMaxPwdAge Then
PassExpStatus = "Expired"
Else
PassExpStatus = "Active"
End If
PassLastChangeDate = DateValue(dtmValue)
PassExpDate = DateValue(dtmValue + intMaxPwdAge)
AFileStream.WriteLine objRecordSet.Fields("Name").Value & chr(09) & PassExpStatus & _
chr(09) & PassLastChangeDate & chr(09) & PassExpDate
End If
objRecordSet.MoveNext
End If
Loop
AFileStream.Close
MsgBox "Done! (passwords expire after " & intMaxPwdAge & " days)"
Raw
2vba.vbs
' Ибитая тема, но все равно очень часто затрагиваемая, смена паролей Администраторов на локальных машинах в домене.
' Скрипт .vbs, добавлять в Startup Scripts.
On Error Resume Next
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery ("Select * from Win32_UserAccount Where LocalAccount = True")
For Each objItem in colItems
If Left (objItem.SID, 6) = "S-1-5-" and Right(objItem.SID, 4) = "-500" Then
Set objUser = GetObject("WinNT://" & strComputer & "/" & objItem.name & ",user")
objUser.SetPassword "PassW0rd"
objUser.SetInfo
End If
Next
Скрипт копирования данных на удаленный комп через Microsoft-скую утилиту Robocopy.
Скрипт редварительно проверяет доступность хоста по сети, затем начинает процесс копирования, по окончании процесса извещает админа по почте с прикрепленном файлом логов-отчета работы скрипта. Этот скрипт удобно использовать при копировании больших обемов данных в нестабильном доступе к удаленному ПК. Я лично запускаю процесс копирования через 10-мегабитную сеть 50 ГБайт. Копируется приблизительно 3 суток, временно прерываясь на период выключения удаленного ПК.
Код:
Option Explicit
Dim LogEvent,PC,PcHost,Host
Dim TargetFolder,SourthFolder,StaticLogFilePath,CurrentLogFilePath,CurrentFolder,ParentFolder,Suffix
Dim SourceAddress, TargetMail, Theme, Text, FileAttachement,SendEmailPath
Dim ForWriting,ForAppending
Dim objFSO,Wshshell
Dim objStaticLogFile,objCurrentLogFile,WSHNetwork
Dim i
'***************************************
'***************************************
'********* Блок Данных *********
'***************************************
'***************************************
PC="PcName" 'Имя удаленного компа
SourthFolder="D:\BackUp\BackUp\File_Server\Folder" ' копируемая папка
StaticLogFilePath="D:\BackUp\BackUp\RobocopyStaticLogFile.txt" 'Статичный файл Логов работы скрипта, т.е. дозаписывается при каждом запуске скрипта
CurrentLogFilePath=SourthFolder&"\RobocopyCurrentLogFile.txt" 'Динамичный файл Логов работы скрипта, т.е. перезаписывается при каждом запуске скрипта он же отправляется по почте
' Таким образом отправляемое письмо содержит информацию только о результате работы текущего запуска скрипта.
SendEmailPath="D:\BackUp\rar\SendEmail.exe" ' утилита для отсыла по почте отчета админу
SourceAddress="File-Server@mydomain.ru"
TargetMail="JohnDoe@mydomain.ru" ' John Doe надеюсь не зарегистрированный товарный знак Microsoft ;-D
Theme="Sending mail from Copying Script"
Text="This Mail Generate with Copying Script About BackUp of File-Server. " ' Тескт в теле письма
FileAttachement=CurrentLogFilePath ' прикрепляемый файл. в данном случае динамичный файл логов см. выше разъяснение динамичного файла логов.
ForWriting=2
ForAppending=8
'***************************************
'***************************************
'***** Конец Блока Данных *******
'***************************************
'***************************************
'***************************************
'***************************************
'***** Блок Объектных переменых ***
'***************************************
'***************************************
set objFSO=CreateObject("Scripting.FileSystemObject")
Set Wshshell=CreateObject("Wscript.Shell")
Set objStaticLogFile=objFSO.OpenTextFile(StaticLogFilePath,ForAppending,true)
Set objCurrentLogFile=objFSO.OpenTextFile(CurrentLogFilePath,ForWriting,true)
Set WSHNetwork = WScript.CreateObject("WScript.Network")
'***************************************
'***************************************
'** Конец Блока Объектных переменых **
'***************************************
'***************************************
LogEvent="Программа копирования архива Файл-сервера запущена."
GatheringEventInLogFiles
LogEvent="Будут скопировано содержимое папки: "&SourthFolder&" Данное окно извещения будет висеть на мониторе 10 секунд."
GatheringEventInLogFiles ' запись в логи сообщения верхней строки.
WshShell.PopUp LogEvent,10
'***************************************
'***************************************
'********* Блок Копирования *********
'***************************************
'***************************************
If objFSO.FolderExists(SourthFolder) Then 'Проверка существования архива на сервере
LogEvent="Проверка существования папки на сервере....-Существует."
GatheringEventInLogFiles
Else
LogEvent="Проверка существования папки на сервере....-Несуществует!!!"
GatheringEventInLogFiles
LogEvent=" Попытка Уведомления Почтой "
GatheringEventInLogFiles
WshShell.Run SendEmailPath&" -f "&SourceAddress&" -t "&TargetMail&" -u "&chr(34)&Theme&chr(34)&" -s mail.mydomain.ru:25 -m "&chr(34)&Text&chr(34)&" -a "&FileAttachement,,true 'Извещение
LogEvent=" Процесс извещения Почтой Закончен"
GatheringEventInLogFiles
Wscript.Quit
End If
PcHost=PC
AvailableHost
If Host=" on" then
LogEvent="Компьютер {"&PcHost&"} доступен в сети."
GatheringEventInLogFiles
RoboCopy
Else
LogEvent="Компьютер {"&PCHost&"} недоступен в сети. Скопируйте BackUp-архив File-Сервера вручную."
GatheringEventInLogFiles
End If
'***************************************
'***************************************
'***** Конец Блока Копирования *******
'***************************************
'***************************************
'***************************************
'***************************************
'**** Подпрограмма копирования *****
'***************************************
'***************************************
Sub RoboCopy
TargetFolder="\\"&PCHost&"\D$" ' путь копирования
WshNetwork.MapNetworkDrive "Q:",TargetFolder 'подключение в качестве диска
LogEvent=" Начало процедуры копирования на ПК {"&PcHost&"}"
GatheringEventInLogFiles
LogEvent="Архив будет скопирован по пути: "&TargetFolder
GatheringEventInLogFiles
WshShell.Run "D:\BackUp\Rar\Robocopy "&SourthFolder&" Q: /s /z /Copy:DATSOU",,True
WshNetwork.RemoveNetworkDrive "Q:"
LogEvent=" Окончание процедуры копирования на ПК {"&PcHost&"}"
GatheringEventInLogFiles
End Sub
'***************************************
'***************************************
'***** Конец Блока копирования *******
'***************************************
'***************************************
'***************************************
'***************************************
'********* Блок Подпрограммы Сбора Статистики *******
'***************************************
'***************************************
Sub GatheringEventInLogFiles 'Подпрограмма Сбора Статистики
objStaticLogFile.WriteLine "*"&" * "&Now&" *** "&LogEvent
objCurrentLogFile.WriteLine "*"&" * "&Now&" *** "&LogEvent
End Sub
'***************************************
'***************************************
'***** Конец Блока Подпрограммы Сбора Статистики*****
'***************************************
'***************************************
'***************************************
'***************************************
'** Блок Подпрограммы Пингования *******
'***************************************
'***************************************
Sub AvailableHost ' Проверка доступности хоста по сети
Dim objPing
Dim objStatus
set objPing=GetObject("winmgmts:").ExecQuery("select * from Win32_PingStatus where address='"&PcHost&"'")
For Each objStatus in objPing
' --------Обрабатываем ответ
If IsNull(objStatus.StatusCode) or objStatus.StatusCode <> 0 Then
Host=" off"
Else
Host=" on"
End If
Next
End Sub
'***************************************
'***************************************
'***** Конец Блока Подпрограммы Пингования *****
'***************************************
'***************************************
LogEvent="Программа копирования архива File-сервера закончена, Данное окно извещения будет висеть на мониторе 10 секунд"
WshShell.PopUp LogEvent,10
GatheringEventInLogFiles
LogEvent=" Попытка Уведомления Почтой "
GatheringEventInLogFiles
WshShell.Run SendEmailPath&" -f "&SourceAddress&" -t "&TargetMail&" -u "&chr(34)&Theme&chr(34)&" -s mail.mydomain.ru:25 -m "&chr(34)&Text&chr(34)&" -a "&FileAttachement,,true 'Извещение
LogEvent=" Процесс извещения Почтой Закончен"
GatheringEventInLogFiles
Wscript.Quit
Скрипт поиска запущеного процеса, в часности Opera.exe, на удалённых машинах.
Отчёт выводит на экран.
Код:
'************************************************
'Язык: VBScript
'Автор: mr.Soshe (Салий В.В.)
'Версия: 1.0
'************************************************
Set WshShell = CreateObject("WScript.Shell")
WshShell.RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Window Title", "=::= -"
aComputer = array("sys-admin","st-buh","zarplata","ekonom","zam-nach", "laborant","dig-zal","materials","secretar")
Set oExplorer = WScript.CreateObject("InternetExplorer.Application")
oExplorer.Navigate "about:blank"
oExplorer.ToolBar = 0
oExplorer.StatusBar = 1
oExplorer.Width=400
oExplorer.Height = 300
oExplorer.Left = 300
oExplorer.Top = 180
Do While (oExplorer.Busy)
Wscript.Sleep 180
Loop
oExplorer.Visible = 1
sHTML = "<title>Список машин с процессом &quot;Opera&quot;</title><center><b>Подождите пожалуйста. Идёт обработка запроса." & " <br> " & _
"Это может занять некоторое время.</center></b><br><br>"
oExplorer.Document.write sHTML
n = 11
for i=0 to n
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & aComputer(i) & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery ("SELECT * FROM Win32_Process WHERE Name = 'Opera.exe'")
oExplorer.StatusText = int(100/n*i-100/n/2) & " %"
If colProcesses.Count <> 0 Then
oExplorer.Document.write "<center>" & aComputer(i) & "</center>"
end if
oExplorer.StatusText = int(100/n*i) & " %"
next
oExplorer.Document.write "<br><br><center><b>Запрос окончен.</b></center>"
'Wscript.Sleep 10000
'oExplorer.Quit
WshShell.RegDelete "HKCU\Software\Microsoft\Internet Explorer\Main\Window Title"
Подключение сетевого диска от конкретного пользователя.
Код:
Dim WshNetwork
Set WshNetwork = WScript.CreateObject("WScript.Network")
WshNetwork.MapNetworkDrive "q:", "\\192.168.1.100\e$", , "administrator", "password"
Raw
3vba.vbs
Public month_now As Variant
Public Function get_month(Optional num_month As Integer = 1, Optional upcase As Boolean = False, Optional lowcase As Boolean = False, Optional tail As Boolean = False)
On Error Resume Next: Err.Clear
month_no_tail = Choose(num_month,"???","????","??","????","??,"??","??","????,"?????","????","????","????")
month_tail = Choose(num_month,"???","????","???,"????","??","??","??","????","?????","????","????","????")
month_ = IIF(tail, month_tail, month_no_tail)
get_month = IIF(upcase, UCase(month_),IIF(lowcase, LCase(month_), month_))
End Function
Public Function open_run_personal(Optional path_ As String, Optional macro_ As String)
Dim AppEx As Object
On Error Resume Next: Err.Clear
Set AppEx = Application.CreateObject("Excel.Application")
AppEx.Visible = False
AppEx.Workbooks.Open "c:\Users\f0221740\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS"
AppEx.Workbooks.Open path_ '"k:\???????????\???????????-???-.xls"
AppEx.Run macro_ '"??1.CommandButton2_Click"
AppEx.ActiveWorkbook.Close False
AppEx.Quit
Set AppEx = Nothing
End Function
'[{"2","5"}]'
Public Function run_macro(AppEx As Object, Optional macro_, Optional flag As Boolean = False, Optional before_ As Boolean = False, Optional after_ As Boolean = False)
On Error Resume Next: Err.Clear
AppEx.Visible = before_
AppEx.Sheets("?? ????).savesend.Value = flag
For each one in macro_
AppEx.Run macro_(i)
Next one
if after_ then
AppEx.ActiveWorkbook.Close True
AppEx.Quit
Set AppEx = Nothing
End If
End Function
Public Function run_macro(AppEx As Object, Optional macro_, Optional flag As Boolean = False, Optional before_ As Boolean = False, Optional after_ As Boolean = False)
End Function
Public Sub load_att(Optional folder As String, Optional filetype As String, Optional name_def As String = "", Optional sender As String, Optional mn As String)
Dim myolapp As Outlook.Application:Dim myItem As Outlook.MailItem:Dim AppEx As Object
On Error Resume Next: Err.Clear
Set myolapp = CreateObject("Outlook.Application")
Set myNamespace = myolapp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItem = myFolder.Items(myFolder.Items.Count)
Set y = myItem.Attachments
Do Until i = y.Count
If y.Count > 0 Then
mas = Split(y(i).DisplayName, ".")
name_def_type = mas(UBound(mas, 1))
If name_def <> "" Then
folder_ = folder & Day(Now()) & " " & month_now & " " & Year(Now())
CreateObject("Scripting.FileSystemObject").FolderExists(folder_)
y(i).SaveAsFile folder_ & "\" & name_def & "." & name_def_type
End If
Loop
End Sub
i = 0
Do Until i = y.Count
i = i + 1
If y.Count > 0 Then
mas = Split(y(i).DisplayName, ".")
maslen = UBound(mas, 1)
name_def_type = mas(maslen)
'If name_def_type = filetype Then ×àñîâîé ðàñõîä.xlsx
If name_def <> "" Then
folder_ = folder & Day(Now()) & " " & month_now & " " & Year(Now())
MkDir (folder_)
y(i).SaveAsFile folder_ & "\" & name_def & "." & name_def_type
Else
If y(i).DisplayName = "Ñóòêè ÀÐÃ.xls" Then
folder_ = folder
y(i).SaveAsFile folder_ & "\" & "SUT_ALPU" & ".xls"
If Day(Now()) <> 2 Then
Set AppEx = Application.CreateObject("Excel.Application")
AppEx.Visible = False
AppEx.Workbooks.Open "C:\Users\f0221740\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS"
AppEx.Workbooks.Open "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\-=ÑÂÅÐÊÀ_ÑÂÎÄÊÈ_È_ÑÓÒÎÊ_ÀËÏÓ_3=-.xls"
AppEx.Run "Ëèñò1.CommandButton2_Click"
AppEx.ActiveWorkbook.Close False
AppEx.Quit
Set AppEx = Nothing
MsgBox "Ïîëó÷åíà, îáðàáîòàíà ôîðìà ïî ñóòêàì îò ÀËÏÓ", vbInformation, "E-MAIL"
End If
Else
If y(i).DisplayName = "×àñîâîé ðàñõîä.xlsx" Then
folder_ = folder
y(i).SaveAsFile folder_ & "\" & "CH_ALPU" & ".xlsx"
xxxx = MsgBox("Ñîõðàíèòü è îòïðàâèòü àâòîìàòè÷åñêè?", vbYesNoCancel, "???")
If xxxx <> 2 Then
Set AppEx = Application.CreateObject("Excel.Application")
AppEx.Workbooks.Open "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\ÂÂÎÄ_×ÀÑÎÂÛÕ_" & mn & ".xls"
If Hour(Now()) > 16 And Hour(Now()) < 18 Then
If xxxx = 6 Then
AppEx.Visible = False
AppEx.Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").savesend.Value = True
AppEx.Run "Ëèñò14.ALPU_CH_Click"
AppEx.Run "Ëèñò14.CommandButton6_Click"
AppEx.Run "Ëèñò14.CommandButton1_Click"
AppEx.Run "Ëèñò14.CommandButton2_Click"
AppEx.ActiveWorkbook.Close True
AppEx.Quit
Set AppEx = Nothing
End If
If xxxx = 7 Then
AppEx.Visible = True
AppEx.Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").savesend.Value = False
AppEx.Run "Ëèñò14.ALPU_CH_Click"
AppEx.Run "Ëèñò14.CommandButton6_Click"
AppEx.Run "Ëèñò14.CommandButton1_Click"
'AppEx.ActiveWorkbook.Close True
'AppEx.Quit
'Set AppEx = Nothing
End If
Else
If xxxx = 6 Then
AppEx.Visible = False
AppEx.Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").savesend.Value = True
AppEx.Run "Ëèñò14.ALPU_CH_Click"
AppEx.Run "Ëèñò14.CommandButton1_Click"
AppEx.Run "Ëèñò14.CommandButton2_Click"
AppEx.ActiveWorkbook.Close True
AppEx.Quit
Set AppEx = Nothing
End If
If xxxx = 7 Then
AppEx.Visible = True
AppEx.Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").savesend.Value = False
AppEx.Run "Ëèñò14.ALPU_CH_Click"
AppEx.Run "Ëèñò14.CommandButton1_Click"
'AppEx.ActiveWorkbook.Close True
'AppEx.Quit
'Set AppEx = Nothing
End If
End If
Else
xxxxx = MsgBox("Îòêðûòü ÀÂÒÎçàïîëåíèå ÈÌÓÑÀ ÷àñîâûìè?", vbYesNo, "???")
If xxxxx = 6 Then
Link1 = Environ$("USERPROFILE") & "\Ðàáî÷èé ñòîë\" & "IMUS_NEW3.skl"
Shell ("RunDLL32.EXE shell32.dll,ShellExec_RunDLL " & Link1)
End If
End If
End If
folder_ = folder & Day(Now()) & " " & month_now & " " & Year(Now())
On Error Resume Next
MkDir (folder_)
y(i).SaveAsFile folder_ & "\" & y(i).DisplayName
End If
End If
'End If
End If
Loop
err_reportitem:
End Sub
Raw
4vba.vbs
Sub NewMail()
If Hour(Now()) < 11 And Day(Now()) = 1 Then
x = get_month(Month(Now() - 1), False, False, True)
y = get_month(Month(Now() - 1), True, False, False)
Else
x = get_month(Month(Now()), False, False, True)
y = get_month(Month(Now()), True, False, False)
End If
load_att "m:\Post\", CStr(x)
'load_att_filter "D:\Ïî÷òà\", CStr(x), CStr(y)
End Sub
Public Function get_month(Optional num_month As Integer = 1, Optional upcase As Boolean = False, Optional lowcase As Boolean = False, Optional tail As Boolean = False) As String
On Error Resume Next: Err.Clear
month_no_tail = Choose(num_month, "ßíâàðü", "Ôåâðàëü", "Ìàðò", "Àïðåëü", "Ìàé", "Èþíü", "Èþëü", "Àâãóñò", "Ñåíòÿáðü", "Îêòÿáðü", "Íîÿáðü", "Äåêàáðü")
month_tail = Choose(num_month, "ßíâàðÿ", "Ôåâðàëÿ", "Ìàðòà", "Àïðåëÿ", "Ìàÿ", "Èþíÿ", "Èþëÿ", "Àâãóñòà", "Ñåíòÿáðÿ", "Îêòÿáðÿ", "Íîÿáðÿ", "Äåêàáðÿ")
month_ = IIf(tail, month_tail, month_no_tail)
get_month = IIf(upcase, UCase(month_), IIf(lowcase, LCase(month_), month_))
End Function
Public Function open_run_personal(Optional path_ As String, Optional macro_ As String)
Dim AppEx As Object
On Error Resume Next: Err.Clear
Set AppEx = Application.CreateObject("Excel.Application")
AppEx.Visible = False
AppEx.Workbooks.Open "c:\Users\f0221740\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS"
AppEx.Workbooks.Open path_
AppEx.Run macro_
AppEx.ActiveWorkbook.Close False
AppEx.Quit
Set AppEx = Nothing
End Function
'[{"2","5"}]'
Public Function run_macro(AppEx As Object, Optional macro_, Optional flag As Boolean = False, Optional before_ As Boolean = False, Optional after_ As Boolean = False)
On Error Resume Next: Err.Clear
AppEx.Visible = before_
AppEx.Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").savesend.Value = flag
For Each one In macro_
AppEx.Run one
Next one
If after_ Then
AppEx.ActiveWorkbook.Close True
AppEx.Quit
Set AppEx = Nothing
End If
End Function
Public Sub load_att(Optional folder As String, Optional month_now As String)
Dim myolapp As Outlook.Application: Dim myItem As Outlook.MailItem: Dim AppEx As Object
On Error Resume Next: Err.Clear
Set myolapp = CreateObject("Outlook.Application")
Set myNamespace = myolapp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItem = myFolder.Items(1)
Set y = myItem.Attachments
i = 1
folder_ = folder & Day(Now()) & " " & month_now & " " & Year(Now())
If Not CreateObject("Scripting.FileSystemObject").FolderExists(folder_ & "\" & myItem.Subject) Then
If Not CreateObject("Scripting.FileSystemObject").FolderExists(folder_) Then
If Not CreateObject("Scripting.FileSystemObject").FolderExists(folder) Then
MkDir (folder)
End If
MkDir (folder_)
End If
MkDir (folder_ & "\" & myItem.SenderName)
End If
Do Until i > y.Count
If y.Count > 0 Then
mas = Split(y(i).DisplayName, ".")
nname = Join(mas, "(" & CStr(myItem.SentOn) & ").")
name1 = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(nname, "*", ""), "/", ""), "?", ""), ">", ""), "<", ""), """", ""), "\", ""), "|", ""), ":", "")
y(i).SaveAsFile folder_ & "\" & myItem.SenderName & "\" & name1
End If
i = i + 1
Loop
name2 = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(myItem.Subject & "(" & CStr(myItem.SentOn) & ")", "*", ""), "/", ""), "?", ""), ">", ""), "<", ""), """", ""), "\", ""), "|", ""), ":", "")
name_ = folder_ & "\" & myItem.SenderName & "\" & name2 & ".txt"
myItem.SaveAs name_, olTXT
End Sub
Public Sub load_att_filter(Optional folder As String, Optional month_now As String, Optional month_now0 As String)
Dim myolapp As Outlook.Application: Dim myItem As Outlook.MailItem: Dim AppEx As Object
On Error Resume Next: Err.Clear
Set myolapp = CreateObject("Outlook.Application")
Set myNamespace = myolapp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItem = myFolder.Items(1)
Set y = myItem.Attachments
i = 1
If Not CreateObject("Scripting.FileSystemObject").FolderExists(folder) Then
MkDir (folder)
End If
Do Until i > y.Count
If y.Count > 0 Then
'------------------------------------------
If y(i).DisplayName = "Ñóòêè ÀÐÃ.xls" Then
If Day(Now()) <> 2 Then
open_run_personal "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\-=ÑÂÅÐÊÀ_ÑÂÎÄÊÈ_È_ÑÓÒÎÊ_ÀËÏÓ_3=-.xls", "Ëèñò1.CommandButton2_Click"
y(i).SaveAsFile folder & "\" & "SUT_ALPU.xls"
MsgBox "Ïîëó÷åíà, îáðàáîòàíà ôîðìà ïî ñóòêàì îò ÀËÏÓ", vbInformation, "E-MAIL"
End If
End If
'------------------------------------------
'------------------------------------------
If y(i).DisplayName = "×àñîâîé ðàñõîä.xlsx" Then
If Day(Now()) <> 2 Then
y(i).SaveAsFile folder & "\" & "CH_ALPU.xls"
xxxx = MsgBox("Ñîõðàíèòü è îòïðàâèòü àâòîìàòè÷åñêè?", vbYesNoCancel, "???")
If xxxx <> 2 Then
Set AppEx = Application.CreateObject("Excel.Application")
AppEx.Workbooks.Open "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\ÂÂÎÄ_×ÀÑÎÂÛÕ_" & month_now0 & ".xls"
If Hour(Now()) > 16 And Hour(Now()) < 18 Then
If xxxx = 6 Then
run_macro AppEx, Array("Ëèñò14.ALPU_CH_Click", "Ëèñò14.CommandButton6_Click", "Ëèñò14.CommandButton1_Click", "Ëèñò14.CommandButton2_Click"), True, False, True
End If
If xxxx = 7 Then
run_macro AppEx, Array("Ëèñò14.ALPU_CH_Click", "Ëèñò14.CommandButton6_Click", "Ëèñò14.CommandButton1_Click"), False, True, False
End If
Else
If xxxx = 6 Then
run_macro AppEx, Array("Ëèñò14.ALPU_CH_Click", "Ëèñò14.CommandButton1_Click", "Ëèñò14.CommandButton2_Click"), True, False, True
End If
If xxxx = 7 Then
run_macro AppEx, Array("Ëèñò14.ALPU_CH_Click", "Ëèñò14.CommandButton1_Click"), False, True, False
End If
End If
Else
xxxxx = MsgBox("Îòêðûòü ÀÂÒÎçàïîëåíèå ÈÌÓÑÀ ÷àñîâûìè?", vbYesNo, "???")
If xxxxx = 6 Then
Link1 = Environ$("USERPROFILE") & "\Ðàáî÷èé ñòîë\" & "IMUS_AUTOTYPE.skl"
Shell ("RunDLL32.EXE shell32.dll,ShellExec_RunDLL " & Link1)
End If
End If
End If
End If
'------------------------------------------
End If
i = i + 1
Loop
End Sub
Raw
userss.vbs
' ==========================================================================
'
' This script demonstrates several techniques to retrieve user names,
' computer names, domain names and some related properties.
'
' Just run it to see which techniques work in your environment and which
' ones don't. This script won't change anything on your computer, it only
' reads some properties.
'
' ==========================================================================
Option Explicit
Dim arrDomainRole( 5 ), colItems, objIP, objItem, objJava, objLM
Dim objReg, objSysInfo, objWMISvc, strHostname, wshNetwork, wshShell
On Error Resume Next
' ==========================================================================
' Except for "Logon Server" and "User Domain", the next technique will work
' on any computer running Windows NT 4, 2000, XP, Server 2003 or Vista,
' wether stand-alone, in a workgroup, NT or AD domain.
' "Logon Server" and "User Domain" will be empty on stand-alone machines.
' This technique doesn't work on Windows 95/98/ME machines.
' ==========================================================================
Set wshShell = Wscript.CreateObject( "Wscript.Shell" )
WScript.Echo "Windows Environment Variables:"
WScript.Echo "=============================="
WScript.Echo "Computer Name : " & wshShell.ExpandEnvironmentStrings( "%COMPUTERNAME%" )
WScript.Echo "Logon Server : " & wshShell.ExpandEnvironmentStrings( "%LOGONSERVER%" )
WScript.Echo "User Domain : " & wshShell.ExpandEnvironmentStrings( "%USERDOMAIN%" )
WScript.Echo "User Name : " & wshShell.ExpandEnvironmentStrings( "%USERNAME%" )
WScript.Echo
Set wshShell = Nothing
' ==========================================================================
' This technique should work on any Windows computer with WSH installed
' (wich excludes 95), wether stand-alone, in a workgroup, NT or AD domain.
' Requires WSH, so it won't work in HTAs.
' ==========================================================================
Set wshNetwork = Wscript.CreateObject( "Wscript.Network" )
WScript.Echo "WSHNetwork:"
WScript.Echo "==========="
WScript.Echo "Computer Name : " & wshNetwork.ComputerName
WScript.Echo "User Domain : " & wshNetwork.UserDomain
WScript.Echo "User Name : " & wshNetwork.UserName
WScript.Echo
Set wshShell = Nothing
' ==========================================================================
' Except for "PDC" and "User Domain", the following next will work on any
' computer running NT 4 or later, wether in a workgroup, NT or AD domain.
' "PDC" will be empty on stand-alones or workgroup members.
' "User Domain" will be empty on stand-alones.
' This technique works on Windows 95/98/ME machines too, if AD client
' software is installed.
' ==========================================================================
Set objSysInfo = CreateObject( "WinNTSystemInfo" )
WScript.Echo "ADSI (WinNTSystemInfo):"
WScript.Echo "======================="
WScript.Echo "Computer Name : " & objSysInfo.ComputerName
WScript.Echo "PDC : " & objSysInfo.PDC
WScript.Echo "User Domain : " & objSysInfo.DomainName
WScript.Echo "User Name : " & objSysInfo.UserName
WScript.Echo
Set objSysInfo = Nothing
' ==========================================================================
' The next technique requires Active Directory.
' It doesn't work on stand-alones or computers in a workgroup or NT domain.
' This technique works on Windows 95/98/ME machines too, if AD client
' software is installed.
' Use custom error handling when using this technique.
' ==========================================================================
Set objSysInfo = CreateObject( "ADSystemInfo" )
WScript.Echo "ADSI (ADSystemInfo):"
WScript.Echo "===================="
WScript.Echo "Computer Name : " & objSysInfo.ComputerName
WScript.Echo "User Domain : " & objSysInfo.DomainName
WScript.Echo "User Name : " & objSysInfo.UserName
WScript.Echo
Set objSysInfo = Nothing
' ==========================================================================
' The next technique will work on any WMI enabled computer, wether
' stand-alone, in a workgroup,' NT domain or AD domain.
' Domain related properties will be empty on stand-alone machines or
' workgroup menmbers.
' "Workgroup" is unreliable, as it often doesn't even work on workgroup
' members running Windows XP Professional SP2.
' This technique works on Windows 95/98/ME machines, if they have WMI
' enabled.
' ==========================================================================
Set objWMISvc = GetObject( "winmgmts:\\.\root\cimv2" )
Set colItems = objWMISvc.ExecQuery( "Select * from Win32_ComputerSystem", , 48 )
WScript.Echo "WMI (Win32_ComputerSystem class):"
WScript.Echo "================================="
arrDomainRole( 0 ) = "Standalone Workstation"
arrDomainRole( 1 ) = "Member Workstation"
arrDomainRole( 2 ) = "Standalone Server"
arrDomainRole( 3 ) = "Member Server"
arrDomainRole( 4 ) = "Backup Domain Controller"
arrDomainRole( 5 ) = "Primary Domain Controller"
For Each objItem in colItems
WScript.Echo "Computer Domain : " & objItem.Domain
WScript.Echo "Domain Role : " & arrDomainRole( objItem.DomainRole )
WScript.Echo "Computer Name : " & objItem.Name
WScript.Echo "Part Of Domain : " & objItem.PartOfDomain
WScript.Echo "User Name : " & objItem.UserName
WScript.Echo "Workgroup : " & objItem.Workgroup
WScript.Echo
Next
Set colItems = Nothing
Set objWMISvc = Nothing
' ==========================================================================
' The next technique requires Windows XP, Server 2003 or Vista, and an NT or
' Active Directory domain.
' It doesn't work on stand-alones or computers in a workgroup.
' Nor does it work in Windows 95, 98, ME, NT 4 or 2000.
' Use custom error handling when using this technique.
' ==========================================================================
WScript.Echo "WMI (Win32_NTDomain class):"
WScript.Echo "==========================="
Set objWMISvc = GetObject("winmgmts:\\.\root\CIMV2")
Set colItems = objWMISvc.ExecQuery("SELECT * FROM Win32_NTDomain", "WQL", 48 )
For Each objItem In colItems
WScript.Echo "Computer Domain : " & objItem.DomainName
If objItem.DSPrimaryDomainControllerFlag Then
WScript.Echo "PDC : " & objItem.DomainControllerName
Else
WScript.Echo "DC : " & objItem.DomainControllerName
End If
WScript.Echo "DC is AD Server : " & objItem.DSDirectoryServiceFlag
WScript.Echo
Next
Set colItems = Nothing
Set objWMISvc = Nothing
' ==========================================================================
' The next technique uses the native WSH Shell object to read the host name
' from the registry.
' This will work in Windows 2000 and later, but I'm not sure about earlier
' Windows versions.
' ==========================================================================
WScript.Echo "Registry (WSH Shell):"
WScript.Echo "====================="
Set wshShell = CreateObject( "WScript.Shell" )
WScript.Echo "Host Name : " & wshShell.RegRead( "HKLM\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Hostname" )
Set wshShell = Nothing
WScript.Echo
' ==========================================================================
' The next technique will work on any WMI enabled computer, wether
' stand-alone, in a workgroup,' NT domain or AD domain.
' It does require a TCP/IP based network, which is standard for Windows.
' This technique works on Windows 95/98/ME machines, if they have WMI
' enabled.
' ==========================================================================
Const HKLM = &H80000002
WScript.Echo "Registry (WMI StdRegProv):"
WScript.Echo "=========================="
Set objReg = GetObject( "winmgmts:{impersonationLevel=impersonate}!//./root/default:StdRegProv" )
objReg.GetStringValue HKLM, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters", "Hostname", strHostname
Set objReg = Nothing
WScript.Echo "Host Name : " & strHostname
WScript.Echo
' ==========================================================================
' The next technique requires System Scripting Runtime by Franz Krainer,
' available at http://www.netal.com/ssr.htm
' Use custom error handling when using this technique, as this is not native
' in Windows.
' ==========================================================================
WScript.Echo "System Scripting Runtime:"
WScript.Echo "========================="
Set objLM = CreateObject( "SScripting.LMNetwork" )
WScript.Echo "Computer Name : " & objLM.ComputerName
Set objLM = Nothing
Set objSysInfo = CreateObject( "SScripting.System" )
WScript.Echo "User Name : " & objSysInfo.UserName
Set objSysInfo = Nothing
Set objIP = CreateObject( "SScripting.IPNetwork" )
WScript.Echo "Computer Domain : " & objIP.Domain
WScript.Echo "Host Name : " & objIP.Hostname
WScript.Echo "IP address of www.google.com: " & objIP.DNSLookup( "www.google.com" )
WScript.Sleep 1000
Set objIP = Nothing
WScript.Echo
' ==========================================================================
' The next technique requires Java Webstart and a TCP/IP based network.
' Use custom error handling when using this technique, as Java is not native
' in Windows.
' ==========================================================================
WScript.Echo "Java Webstart:"
WScript.Echo "=============="
Set objJava = CreateObject( "JavaWebStart.isInstalled" )
WScript.Echo "IP address of www.google.com: " & objJava.dnsResolve( "www.google.com" )
Set objJava = Nothing
WScript.Echo
On Error Goto 0
Raw
vvod_ch.vbs
Private Sub ALPU_CH_Click()
Dim r As Range
Dim name_1, name_2 As String
Dim Ex As New Excel.Application
On Error Resume Next
default_book_name = ActiveWorkbook.Name
current_day = Day(Now())
If current_day <= 9 Then
current_day = "0" & current_day
End If
time_now = Hour(Now())
If time_now >= 11 Then
If time_now >= 15 Then
If time_now >= 19 Then
cur_ch = "P"
Else
cur_ch = "N"
End If
Else
cur_ch = "L"
End If
Else
cur_ch = "J"
End If
tab_settings = "spisok_002"
ch_tab = "ÂÂÎÄ ×ÀÑÎÂÛÕ"
settings_find_col = "J"
settings_find_znach = "path_form_alpu"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ex.Visible = False
znach_path = Workbooks(default_book_name).Sheets(tab_settings).Cells(Sheets(tab_settings).Columns(settings_find_col & ":" & settings_find_col).Find(What:=settings_find_znach, LookIn:=xlValues).Row, 1).Value
znach = Split(znach_path, "\")
zhach_len = UBound(znach)
znach_name = znach(zhach_len)
Ex.Workbooks.Open znach_path
'Workbooks(default_book_name).Sheets(ch_tab).Range("A:B").ClearContents
'dnowcol = Ex.Workbooks(alpu).Sheets("ËÏÓÌÃ").Rows(2).Find(What:=dnow, LookIn:=xlValues).Column
i = 1
For Each r In Ex.Workbooks(znach_name).Sheets(current_day).Range("B:B")
If IsEmpty(r) = False Then
If r.Value = "ÃÐÑ-3 ã. Áàðíàóë (2 âûõîä)" Then
Workbooks(default_book_name).Sheets(ch_tab).Cells(Sheets(ch_tab).Columns("A:A").Find(What:=r.Value, LookIn:=xlValues).Row, "B").Value = Ex.Workbooks(znach_name).Sheets(current_day).Cells(r.Row, cur_ch).Value + Ex.Workbooks(znach_name).Sheets(current_day).Cells(r.Row - 1, cur_ch).Value
Else
Workbooks(default_book_name).Sheets(ch_tab).Cells(Sheets(ch_tab).Columns("A:A").Find(What:=r.Value, LookIn:=xlValues).Row, "B").Value = Ex.Workbooks(znach_name).Sheets(current_day).Cells(r.Row, cur_ch).Value
'Workbooks(default_book_name).Sheets(ch_tab).Cells(i, 1) = r.Value
'Workbooks(default_book_name).Sheets(ch_tab).Cells(i, 3) = Ex.Workbooks(znach_name).Sheets(current_day).Cells(r.Row, cur_ch).Value
End If
i = i + 1
Else
If exit1 < 10 Then
exit1 = exit1 + 1
Else
GoTo exit1_
End If
End If
Next r
exit1_:
Ex.Workbooks(znach_name).Close False
Set Ex = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub CommandButton1_Click()
sum_ = 0
Application.ScreenUpdating = False
Sheets("edit").Range("N10:V150").Value = ""
For Each r In Sheets("edit").Range("I10:I150")
If r.Value <> "" And Left(Sheets("edit").Cells(r.Row, 13).Formula, 1) <> "=" Then
On Error Resume Next
'Sheets("edit").Cells(r.Row, 14).Value = Sheets("×ÀÑÎÂÛÅ").Cells(Sheets("×ÀÑÎÂÛÅ").Cells.Find(What:=r.Value, After:=ActiveCell, LookIn:=xlValues, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False, SearchFormat:=False).Row, 2).Value
row_00 = Sheets("×ÀÑÎÂÛÅ").Columns("G:J").Find(What:=r.Value, LookIn:=xlValues).Row
col_00 = Sheets("×ÀÑÎÂÛÅ").Columns("G:J").Find(What:=r.Value, LookIn:=xlValues).Column
Sheets("edit").Cells(r.Row, 14).Value = Sheets("×ÀÑÎÂÛÅ").Cells(row_00, col_00 - 4).Value
Sheets("edit").Cells(r.Row, 16).Value = col_00
Sheets("edit").Cells(r.Row, 17).Value = row_00
End If
Next r
For Each r_ In Sheets("edit").Range("Q10:Q150")
sssum = Sheets("edit").Cells(r_.Row, 13).Value
For Each r__ In Sheets("edit").Range("Q10:Q150")
If r__.Value = r_.Value And r_.Row <> r__.Row And r__.Value <> "" Then
sssum = sssum + Sheets("edit").Cells(r__.Row, 13).Value
End If
Next r__
For Each r__ In Sheets("edit").Range("Q10:Q150")
'If r__.Value = r_.Value And r_.Row <> r__.Row And r__.Value <> "" Then
If r__.Value = r_.Value And r__.Value <> "" Then
Sheets("edit").Cells(r__.Row, 18).Value = sssum
End If
Next r__
sssum = 0
Next r_
'------------------
'------------------
For Each r_1 In Sheets("edit").Range("R10:R150")
If Sheets("edit").Cells(r_1.Row, 18).Value <> 0 Then
Sheets("edit").Cells(r_1.Row, 19).Value = Sheets("edit").Cells(r_1.Row, 13).Value / Sheets("edit").Cells(r_1.Row, 18).Value
Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 14).Value '* Sheets("edit").Cells(r_1.Row, 19).Value
If Sheets("edit").Cells(r_1.Row, 17).Value = 10 And Sheets("edit").Cells(r_1.Row, 19).Value <> 0 Then
If Sheets("edit").Cells(r_1.Row - 1, 19).Value <> 0 Then
'Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 20).Value - Sheets("edit").Cells(r_1.Row - 1, 14).Value
End If
End If
If Sheets("edit").Cells(r_1.Row, 20).Value > Sheets("edit").Cells(r_1.Row, 13).Value And Sheets("edit").Cells(r_1.Row, 10).Value <> "ÏÐÅÄÏÐÈßÒÈÅ" And Sheets("edit").Cells(r_1.Row, 9).Value <> "2709606642662501" Then
Sheets("edit").Cells(r_1.Row, 21).Value = Sheets("edit").Cells(r_1.Row, 20).Value - Sheets("edit").Cells(r_1.Row, 13).Value
Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 13).Value
End If
End If
If Sheets("edit").Cells(r_1.Row, 17).Value = 17 Or Sheets("edit").Cells(r_1.Row, 17).Value = 16 Then
Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 14).Value
If Sheets("edit").Cells(r_1.Row, 20).Value > Sheets("edit").Cells(r_1.Row, 13).Value Then
Sheets("edit").Cells(r_1.Row, 21).Value = Sheets("edit").Cells(r_1.Row, 20).Value - Sheets("edit").Cells(r_1.Row, 13).Value
Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 13).Value
End If
End If
x = x + Sheets("edit").Cells(r_1.Row, 21).Value
''''If Sheets("edit").Cells(r_1.Row, 17).Value = 16 Then 'ðîñíåôòü áï
'''' Sheets("edit").Cells(r_1.Row, 20).Value = x * Sheets("ÁÏÐÍ").Cells(28, 4).Value + Sheets("edit").Cells(r_1.Row, 14).Value + Sheets("×ÀÑÎÂÛÅ").Cells(19, 2).Value - Sheets("×ÀÑÎÂÛÅ").Cells(19, 3).Value - Sheets("ÁÏÐÍ").Cells(19, 3).Value
''''End If
' If Sheets("edit").Cells(r_1.Row, 17).Value = 16 Then 'ðîñíåôòü áï
' Sheets("edit").Cells(r_1.Row, 20).Value = x + Sheets("edit").Cells(r_1.Row, 14).Value + Sheets("×ÀÑÎÂÛÅ").Cells(19, 2).Value - Sheets("×ÀÑÎÂÛÅ").Cells(19, 3).Value - Sheets("ÁÏÐÍ").Cells(19, 3).Value
' End If
'''' If Sheets("edit").Cells(r_1.Row, 17).Value = 24 Then
'''' Sheets("edit").Cells(r_1.Row, 20).Value = x * Sheets("ÁÏÐÍ").Cells(29, 4).Value + Sheets("ÁÏÐÍ").Cells(19, 3).Value '
''''End If
If Sheets("edit").Cells(r_1.Row, 17).Value = 49 Then 'ðîñíåôòü áï
Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(r_1.Row, 14).Value + x '+ Sheets("×ÀÑÎÂÛÅ").Cells(19, 2).Value - Sheets("×ÀÑÎÂÛÅ").Cells(19, 3).Value + x
End If
'''''If Sheets("edit").Cells(r_1.Row, 17).Value = 24 Then
''''' Sheets("edit").Cells(r_1.Row, 20).Value = x * Sheets("ÁÏÐÍ").Cells(29, 4).Value + Sheets("ÁÏÐÍ").Cells(19, 3).Value '
'''''End If
'--------------
If Sheets("edit").Cells(r_1.Row, 10).Value = "ÑÂÎÄÍÀß" Or Sheets("edit").Cells(r_1.Row, 10).Value = "ÃÐÑ" Then
Sheets("edit").Cells(r_1.Row, 23).Value = r_1.Row
sum_ = 0
Else
If Sheets("edit").Cells(r_1.Row, 10).Value = "ÏÐÅÄÏÐÈßÒÈÅ" Then
Sheets("edit").Cells(r_1.Row, 23).Value = Sheets("edit").Cells(r_1.Row - 1, 23).Value
sum_ = sum_ + Sheets("edit").Cells(r_1.Row, 20).Value
If Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 14).Value < Sheets("edit").Cells(r_1.Row, 23).Value And Sheets("edit").Cells(r_1.Row, 20).Value <> 0 Then
'Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
End If
Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 24).Value = sum_
'If Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 24).Value > Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value Then
'Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 20).Value = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
'If Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value > Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 14).Value Then
'x = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 14).Value
'y = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
'End If
End If
End If
'---------------
Next r_1
'''===
For Each r_2 In Sheets("edit").Range("R10:R150")
If Sheets("edit").Cells(r_2.Row, 10).Value = "ÏÐÅÄÏÐÈßÒÈÅ" Then
If Sheets("edit").Cells(r_2.Row, 23).Value > 0 Then
If Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 24).Value <> 0 Then
Sheets("edit").Cells(r_2.Row, 25).Value = Sheets("edit").Cells(r_2.Row, 20).Value / Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 24).Value
End If
If Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 9).Value <> "2709606642662501" Then '---
If Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 24).Value > Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 14).Value Then
Sheets("edit").Cells(r_2.Row, 20).Value = (Sheets("edit").Cells(Sheets("edit").Cells(r_2.Row, 23).Value, 20).Value) * Sheets("edit").Cells(r_2.Row, 25).Value
End If
End If '----
End If
End If
Next r_2
'''===
Sheets("edit").Cells(Sheets("edit").Columns("K:K").Find(What:="Èñïîëíèòåëü:", LookIn:=xlValues).Row, "L").Value = Sheets("spisok_001").Cells(1, 3).Value
Sheets("edit").Range("A1") = Sheets("edit").Columns("K:K").Find(What:="Èñïîëíèòåëü:", LookIn:=xlValues).Row
Dim r_0 As Range
Dim name_1, name_2 As String
Dim Ex As New Excel.Application
def_wb = ActiveWorkbook.Name
def_tab = ActiveSheet.Name
meta_list = "edit"
meta_list1 = "edit_ga"
'name_1 = Right(Workbooks(def_wb).Sheets("spisok_002").Cells(3, 1).Value, Len(Workbooks(def_wb).Sheets("spisok_002").Cells(3, 1).Value) - 44)
'name_2 = Right(Workbooks(def_wb).Sheets("spisok_002").Cells(4, 1).Value, Len(Workbooks(def_wb).Sheets("spisok_002").Cells(4, 1).Value) - 44)
Application.ScreenUpdating = False
t = Workbooks(def_wb).Sheets(def_tab).Cells(31, 2).Value
dispetcher = Workbooks(def_wb).Sheets("spisok_001").Cells(1, 3).Value
time_4as = Workbooks(def_wb).Sheets("spisok_003").Cells(1, 2).Value
Ex.Workbooks.Open Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_ch_ak", LookIn:=xlValues).Row, 1).Value
Ex.Workbooks.Open Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_ch_ga", LookIn:=xlValues).Row, 1).Value
name_1 = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="name_ch_ak", LookIn:=xlValues).Row, 1).Value
name_2 = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="name_ch_ga", LookIn:=xlValues).Row, 1).Value
'Workbooks.Open Filename:=Workbooks(def_wb).Sheets(meta_list).Cells(1, 13).Value
'name_1 = ActiveWorkbook.Name
'Workbooks.Open Filename:=Workbooks(def_wb).Sheets(meta_list).Cells(2, 13).Value
'name_2 = ActiveWorkbook.Name
Ex.Application.Calculation = xlCalculationManual
Ex.Workbooks(name_1).Sheets(time_4as).Activate
For Each r_0 In Workbooks(def_wb).Sheets(meta_list).Range("T10:T150")
If r_0.Value <> "" Then
Ex.Workbooks(name_1).Sheets(time_4as).Cells(r_0.Row, "N").Value = Workbooks(def_wb).Sheets(meta_list).Cells(r_0.Row, "T").Value
End If
Next r_0
Ex.Workbooks(name_1).Sheets(time_4as).Cells(Workbooks(def_wb).Sheets(meta_list).Range("A1").Value, 11) = dispetcher
Ex.Workbooks(name_1).Sheets(time_4as).Range("E4").Value = t
'Ex.Workbooks(name_2).Sheets(time_4as).Range("K32").Value = dispetcher
'Ex.Workbooks(name_2).Sheets(time_4as).Range("E4").Value = t
'-----------------------------
Sheets("edit_ga").Range("N10:V150").Value = ""
For Each r In Sheets("edit_ga").Range("I10:I150")
If r.Value <> "" And Left(Sheets("edit_ga").Cells(r.Row, 13).Formula, 1) <> "=" Then
On Error GoTo errr
'Sheets("edit").Cells(r.Row, 14).Value = Sheets("×ÀÑÎÂÛÅ").Cells(Sheets("×ÀÑÎÂÛÅ").Cells.Find(What:=r.Value, After:=ActiveCell, LookIn:=xlValues, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False, SearchFormat:=False).Row, 2).Value
row_00 = Sheets("×ÀÑÎÂÛÅ").Columns("G:J").Find(What:=r.Value, LookIn:=xlValues).Row
col_00 = Sheets("×ÀÑÎÂÛÅ").Columns("G:J").Find(What:=r.Value, LookIn:=xlValues).Column
Sheets("edit_ga").Cells(r.Row, 14).Value = Sheets("×ÀÑÎÂÛÅ").Cells(row_00, col_00 - 4).Value
Sheets("edit_ga").Cells(r.Row, 16).Value = col_00
Sheets("edit_ga").Cells(r.Row, 17).Value = row_00
End If
errr:
Next r
For Each r_ In Sheets("edit_ga").Range("Q10:Q150")
For Each r__ In Sheets("edit_ga").Range("Q10:Q150")
If r__.Value = r_.Value And r_.Row <> r__.Row And r__.Value <> "" Then
Sheets("edit_ga").Cells(r__.Row, 18).Value = Sheets("edit_ga").Cells(r__.Row, 13).Value + Sheets("edit_ga").Cells(r_.Row, 13).Value
End If
Next r__
Next r_
For Each r_1 In Sheets("edit_ga").Range("R10:R150")
If Sheets("edit_ga").Cells(r_1.Row, 18).Value <> 0 Then
Sheets("edit_ga").Cells(r_1.Row, 19).Value = Sheets("edit_ga").Cells(r_1.Row, 13).Value / Sheets("edit_ga").Cells(r_1.Row, 18).Value
Sheets("edit_ga").Cells(r_1.Row, 20).Value = Sheets("edit_ga").Cells(r_1.Row, 14).Value * Sheets("edit_ga").Cells(r_1.Row, 19).Value
If Sheets("edit_ga").Cells(r_1.Row, 17).Value = 10 And Sheets("edit_ga").Cells(r_1.Row, 19).Value <> 0 Then
Sheets("edit_ga").Cells(r_1.Row, 20).Value = Sheets("edit_ga").Cells(r_1.Row, 20).Value - Sheets("edit_ga").Cells(r_1.Row - 1, 14).Value
End If
If Sheets("edit_ga").Cells(r_1.Row, 20).Value > Sheets("edit_ga").Cells(r_1.Row, 13).Value And Sheets("edit_ga").Cells(r_1.Row, 10).Value <> "ÏÐÅÄÏÐÈßÒÈÅ" Then
'Sheets("edit_ga").Cells(r_1.Row, 21).Value = Sheets("edit_ga").Cells(r_1.Row, 20).Value - Sheets("edit_ga").Cells(r_1.Row, 13).Value
'Sheets("edit_ga").Cells(r_1.Row, 20).Value = Sheets("edit_ga").Cells(r_1.Row, 13).Value
End If
End If
If Sheets("edit_ga").Cells(r_1.Row, 17).Value = 17 Or Sheets("edit_ga").Cells(r_1.Row, 17).Value = 16 Then
Sheets("edit_ga").Cells(r_1.Row, 20).Value = Sheets("edit_ga").Cells(r_1.Row, 14).Value
If Sheets("edit_ga").Cells(r_1.Row, 20).Value > Sheets("edit_ga").Cells(r_1.Row, 13).Value Then
Sheets("edit_ga").Cells(r_1.Row, 21).Value = Sheets("edit_ga").Cells(r_1.Row, 20).Value - Sheets("edit_ga").Cells(r_1.Row, 13).Value
Sheets("edit_ga").Cells(r_1.Row, 20).Value = Sheets("edit_ga").Cells(r_1.Row, 13).Value
End If
End If
x = x + Sheets("edit_ga").Cells(r_1.Row, 21).Value
If Sheets("edit_ga").Cells(r_1.Row, 17).Value = 16 Then
Sheets("edit_ga").Cells(r_1.Row, 20).Value = x + Sheets("edit_ga").Cells(r_1.Row, 14).Value + x '+ Sheets("×ÀÑÎÂÛÅ").Cells(19, 2).Value - Sheets("×ÀÑÎÂÛÅ").Cells(19, 3).Value
End If
'===========
If Sheets("edit_ga").Cells(r_1.Row, 10).Value = "ÑÂÎÄÍÀß" Or Sheets("edit_ga").Cells(r_1.Row, 10).Value = "ÃÐÑ" Then
Sheets("edit_ga").Cells(r_1.Row, 23).Value = r_1.Row
sum_ = 0
Else
If Sheets("edit_ga").Cells(r_1.Row, 10).Value = "ÏÐÅÄÏÐÈßÒÈÅ" Then
Sheets("edit_ga").Cells(r_1.Row, 23).Value = Sheets("edit_ga").Cells(r_1.Row - 1, 23).Value
sum_ = sum_ + Sheets("edit_ga").Cells(r_1.Row, 20).Value
If Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_1.Row, 23).Value, 14).Value < Sheets("edit_ga").Cells(r_1.Row, 23).Value And Sheets("edit_ga").Cells(r_1.Row, 20).Value <> 0 Then
'Sheets("edit").Cells(r_1.Row, 20).Value = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
End If
Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_1.Row, 23).Value, 24).Value = sum_
'If Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 24).Value > Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value Then
'Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 20).Value = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
'If Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value > Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 14).Value Then
'x = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 14).Value
'y = Sheets("edit").Cells(Sheets("edit").Cells(r_1.Row, 23).Value, 13).Value
'End If
End If
End If
'===========
Next r_1
'===
For Each r_2 In Sheets("edit_ga").Range("R10:R150")
If Sheets("edit_ga").Cells(r_2.Row, 10).Value = "ÏÐÅÄÏÐÈßÒÈÅ" Then
If Sheets("edit_ga").Cells(r_2.Row, 23).Value > 0 Then
If Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_2.Row, 23).Value, 24).Value <> 0 Then
Sheets("edit_ga").Cells(r_2.Row, 25).Value = Sheets("edit_ga").Cells(r_2.Row, 20).Value / Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_2.Row, 23).Value, 24).Value
End If
If Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_2.Row, 23).Value, 24).Value > Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_2.Row, 23).Value, 14).Value Then
Sheets("edit_ga").Cells(r_2.Row, 20).Value = (Sheets("edit_ga").Cells(Sheets("edit_ga").Cells(r_2.Row, 23).Value, 20).Value) * Sheets("edit_ga").Cells(r_2.Row, 25).Value
End If
End If
End If
Next r_2
'===
Sheets("edit_ga").Cells(Sheets("edit_ga").Columns("K:K").Find(What:="Èñïîëíèòåëü:", LookIn:=xlValues).Row, "L").Value = Sheets("spisok_001").Cells(1, 3).Value
Sheets("edit_ga").Range("A1") = Sheets("edit_ga").Columns("K:K").Find(What:="Èñïîëíèòåëü:", LookIn:=xlValues).Row
'-----------------------------
'Ex.Workbooks(name_2).Sheets(time_4as).Range("N29").Value = Workbooks(def_wb).Sheets(meta_list).Range("S19").Value
'Ex.Workbooks(name_2).Sheets(time_4as).Range("N17").Value = Workbooks(def_wb).Sheets(meta_list).Range("S20").Value
'Ex.Workbooks(name_2).Sheets(time_4as).Range("N21").Value = Workbooks(def_wb).Sheets(meta_list).Range("S21").Value
'Ex.Workbooks(name_2).Sheets(time_4as).Range("N28").Value = Workbooks(def_wb).Sheets(meta_list).Range("S22").Value
'Ex.Workbooks(name_2).Sheets(time_4as).Range("N22").Value = Workbooks(def_wb).Sheets(meta_list).Range("T19").Value
Ex.Workbooks(name_2).Sheets(time_4as).Activate
For Each r_0 In Workbooks(def_wb).Sheets(meta_list1).Range("T10:T150")
If r_0.Value <> "" Then
Ex.Workbooks(name_2).Sheets(time_4as).Cells(r_0.Row, "N").Value = Workbooks(def_wb).Sheets(meta_list1).Cells(r_0.Row, "T").Value
End If
Next r_0
Ex.Workbooks(name_2).Sheets(time_4as).Cells(Workbooks(def_wb).Sheets(meta_list1).Range("A1").Value, 11) = dispetcher
Ex.Workbooks(name_2).Sheets(time_4as).Range("E4").Value = t
'Ex.Workbooks(name_2).Sheets(time_4as).Range("K32").Value = dispetcher
'Ex.Workbooks(name_2).Sheets(time_4as).Range("E4").Value = t
Application.ScreenUpdating = True
Ex.Workbooks(name_1).Sheets(time_4as).Calculate
Ex.Workbooks(name_2).Sheets(time_4as).Calculate
Ex.Workbooks(name_1).Sheets(time_4as).Activate
Ex.Workbooks(name_2).Sheets(time_4as).Activate
'
'
'xxxx = MsgBox("Ñîõðàíèòü è íå îòêðûâàòü äëÿ ïðîâåðêè?", vbYesNo, "Ïðîâåðÿòü èëè íåò")
'If xxxx = 6 Then
'Ex.Visible = False
'Ex.Workbooks(name_1).Close True
'Ex.Workbooks(name_2).Close True
'End If
'
'
'If xxxx = 7 Then
'Ex.Visible = True
'End If
If savesend.Value = True Then
Ex.Visible = False
Ex.Workbooks(name_1).Close True
Ex.Workbooks(name_2).Close True
Else
Ex.Visible = True
End If
'Ex.Workbooks(name_2).Sheets(time_4as).Activate
'Application.Calculation = xlCalculationAutomatic
'Ex.Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton20_Click()
nas = Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").Cells(39, "C").Value
defpath = "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\ÏÐÎÃÍÎÇÛ\"
month_ = str_month(Month(Now() + 1), False, False, False) & "\"
month_n = str_month(Month(Now() + 1), False, True, True)
day_0 = Trim(str(Day(Now() - 1)))
day_ = Trim(str(Day(Now())))
day_1 = Trim(str(Day(Now() + 1)))
day_2 = Trim(str(Day(Now() + 2)))
If day_0 <= 9 Then
day_0 = "0" & day_0
End If
If day_ <= 9 Then
day_ = "0" & day_
End If
If day_1 <= 9 Then
day_1 = "0" & day_1
End If
If day_2 <= 9 Then
day_2 = "0" & day_2
End If
bef = defpath & month_ & "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_ & "-" & day_1 & " " & month_n & " 2014.xls"
af = defpath & month_ & "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_1 & "-" & day_2 & " " & month_n & " 2014.xls"
If Day(Now() + 1) = 1 Then
Workbooks.Open af
Sheets("ÀÊ").Cells(9, "D") = nas
Else
FileCopy bef, af
Workbooks.Open af
Sheets("ÀÊ").Cells(1, 1) = Sheets("ÀÊ").Cells(1, 1) + 1
Sheets("ÀÊ").Cells(9, "D") = nas
End If
End Sub
Function str_month(num_month As Integer, upcase As Boolean, lowcase As Boolean, tail As Boolean) As String
On Error Resume Next
Select Case num_month
Case 1:
month_now = "ßíâàðü"
Case 2:
month_now = "Ôåâðàëü"
Case 3:
month_now = "Ìàðò"
Case 4:
month_now = "Àïðåëü"
Case 5:
month_now = "Ìàé"
Case 6:
month_now = "Èþíü"
Case 7:
month_now = "Èþëü"
Case 8:
month_now = "Àâãóñò"
Case 9:
month_now = "Ñåíòÿáðü"
Case 10:
month_now = "Îêòÿáðü"
Case 11:
month_now = "Íîÿáðü"
Case 12:
month_now = "Äåêàáðü"
End Select
If upcase Then
month_now = UCase(month_now)
End If
If lowcase Then
month_now = LCase(month_now)
End If
If tail Then
If num_month <> 3 And num_month <> 8 Then
month_now = Left(month_now, Len(month_now) - 1) & "ÿ"
Else
month_now = month_now & "à"
End If
End If
str_month = month_now
End Function
Private Sub CommandButton9_Click()
dd = Day(Now - 1)
dd = dd + 1
def_wb = ActiveWorkbook.Name
def_tab = ActiveSheet.Name
meta_list = "entry"
trans = "Áàðíàóëòðàíñìàø ÎÀÎ ÕÊ"
ashk = "Àëòàéñêèé øèííûé êîìáèíàò ÎÀÎ ÏÎ"
ind = "Èíäóñòðèàëüíûé ÎÀÎ (ã. Áàðíàóë, Ïàâëîâñêèé òðàêò, 337)"
ener = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ ÃÐÑ-3 ã. Áàðíàóëà"
ener1 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ ÃÐÑ-2 ã. Áàðíàóëà (Ïðèãîðîäíîå ÓÕ) "
ener2 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ ÃÐÑ-1 ã. Áàðíàóëà"
ener3 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹ 6): ã. Áàðíàóë, óë. Ãîãîëÿ, 16"
ener4 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹7): ã. Áàðíàóë, óë. Àâàíåñîâà, 32"
vag = "Àëòàéâàãîí ÎÀÎ"
gt = "ÃÒ-ÒÝÖ Ýíåðãî "
t1 = "Êóçáàññýíåðãî ÎÀÎ ÒÝÖ-1"
'__________________________________________
bp1 = "Êóçáàññýíåðãî ÎÀÎ ÒÝÖ-2"
bp2 = "Êóçáàññýíåðãî ÎÀÎ ÒÝÖ-3"
bp3 = "Êóçáàññýíåðãî ÎÀÎ ÐÂÊ"
bp4 = "Àëòàéâàãîí ÎÀÎ "
bp5 = "Àëòàéêðîâëÿ ÇÀÎ "
bp6 = "×åðåìíîâñêèé ñàõàðíûé çàâîä ÎÀÎ"
bp7 = "Òàëüìåíñêèé ñåëüõîçòåõíèêóì ÔÃÎÓ ÑÏÎ "
'__________________________________________
Application.ScreenUpdating = False
tt = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_sut_ak", LookIn:=xlValues).Row, 1).Value
Workbooks.Open Filename:=tt
Sheets("Ñâîäêà çà ìåñÿö").Select
w_b = ActiveWorkbook.Name
w_s = ActiveSheet.Name
w__s = "entry"
Workbooks(def_wb).Sheets(def_tab).Cells(33, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=vag, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(34, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=trans, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(30, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ashk, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(31, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ind, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
en1 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ener, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
en2 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ener1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
en3 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ener2, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
en4 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ener3, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
en5 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=ener4, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(32, 3).Value = en1 + en2 + en3 + en4 + en5
Workbooks(def_wb).Sheets(def_tab).Cells(22, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=gt, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(27, 3).Value = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=t1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
'__________________________________________
tk = "Ãîðíî-Àëòàéñêàÿ òåïëîâàÿ êîìïàíèÿ ÎÎÎ"
'------------------------------
nas1 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-2 ã. Áèéñêà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas2 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ ã. Áåëîêóðèõà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas3 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-3 ã. Áèéñêà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas4 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-Àëòàéñêîå)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas5 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-Ñìîëåíñêîå)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas6 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-Ñîâåòñêîå)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas7 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Âûïîëçîâî)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas8 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ ã. Íîâîàëòàéñêà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas9 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Êîìñîìîëüñêàÿ)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas10 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Êîñèõà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas11 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Ïåðâîìàéñêàÿ)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas12 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Ñèáèðñêàÿ)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas13 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Òàëüìåíêà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas14 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ Òðîèöêîå)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas15 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-1 ã. Áàðíàóëà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas16 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-2 ã. Áàðíàóëà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
nas17 = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:="Íàñåëåíèå (ÃÐÑ-3 ã. Áàðíàóëà)", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
Workbooks(def_wb).Sheets(def_tab).Cells(35, 3).Value = nas1 + nas2 + nas3 + nas4 + nas5 + nas6 + nas7 + nas8 + nas9 + nas10 + nas11 + nas12 + nas13 + nas14 + nas15 + nas16 + nas17
'------------------------------
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
ttt = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_sut_ga", LookIn:=xlValues).Row, 1).Value
Workbooks.Open Filename:=ttt
Sheets("Ñâîäêà çà ìåñÿö").Select
w_b1 = ActiveWorkbook.Name
w_s1 = ActiveSheet.Name
Workbooks(def_wb).Sheets(def_tab).Cells(37, 3).Value = Workbooks(w_b1).Sheets(w_s1).Cells(Workbooks(w_b1).Sheets(w_s1).Cells.Find(What:=tk, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
ActiveWorkbook.Saved = True
ActiveWindow.Close
Application.ScreenUpdating = True
Workbooks(def_wb).Sheets(def_tab).Activate
End Sub
Private Sub CommandButton4_Click()
End Sub
Private Sub smena_Click()
DialogSheets("smena").Show
Call all_now
End Sub
Private Sub time_Click()
DialogSheets("time").Show
Call all_now
End Sub
Private Sub all_now()
Sheets("×ÀÑÎÂÛÅ").Cells(1, 2).Value = "Òåêóùèé èñïîëíèòåëü: " & Sheets("spisok_001").Cells(1, 2).Value
Sheets("×ÀÑÎÂÛÅ").Cells(2, 2).Value = "Íà âðåìÿ: " & Sheets("spisok_003").Cells(1, 2).Value
End Sub
Function logs(pam)
i = pam
Select Case Sheets("spisok_003").Range("B1").Value
Case "08-00"
bl = 2
Case "12-00"
bl = 42
Case "16-00"
bl = 82
Case "20-00"
bl = 122
End Select
mrt:
If Sheets("LOGS").Cells(1, i).Value <> Date Then
i = i + 1
GoTo mrt
End If
For Each r In Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").Range("B5:B31")
Sheets("LOGS").Cells(bl, i).Value = r.Value
bl = bl + 1
Next r
For Each r In Sheets("ÂÂÎÄ ×ÀÑÎÂÛÕ").Range("B34:B45")
Sheets("LOGS").Cells(bl, i).Value = r.Value
bl = bl + 1
Next r
End Function
Function izsvak(str, w_b, w_s) As Integer
dd = Day(Now - 1)
dd = dd + 1
izsvak = Workbooks(w_b).Sheets(w_s).Cells(Workbooks(w_b).Sheets(w_s).Cells.Find(What:=str, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row, dd + 1).Value
End Function
Private Sub CommandButton6_Click()
Application.ScreenUpdating = False
On Error Resume Next
def_wb = ActiveWorkbook.Name
def_tab = ActiveSheet.Name
p1 = "Àëòàéâàãîí ÎÀÎ (ã. Íîâîàëòàéñê, óë. 22-ãî Ïàðòñúåçäà, 16)"
p2 = "Àëòàéêðîâëÿ ÇÀÎ (Íîâîàëòàéñê) ã. Íîâîàëòàéñê, óë. Âàãîíîñòðîèòåëüíàÿ, 9"
p3 = "Àëòàéñêèé øèííûé êîìáèíàò ÎÀÎ ÏÎ (Êîòåëüíàÿ): ã. Áàðíàóë, óë. 9-é Çàâîäñêîé ïðîåçä, 48"
p4 = "Èíäóñòðèàëüíûé ÎÀÎ (ã. Áàðíàóë, Ïàâëîâñêèé òðàêò, 337)"
p5 = "Áàðíàóëüñêàÿ òåïëîñåòåâàÿ êîìïàíèÿ ÎÀÎ (ã. Áàðíàóë, ïðîñïåêò Êîñìîíàâòîâ, 14æ (ÐÂÊ) ÁÒÖ ÌÊÓ)"
p6 = "Áàðíàóëüñêàÿ ÒÝÖ-3 ÎÀÎ (ã. Áàðíàóë, óë. Òðàêòîâàÿ, 7, ÒÝÖ-3)"
p7 = "×åðåìíîâñêèé ñàõàðíûé çàâîä ÎÀÎ (ñ. ×åðåìíîå, ïåð. Ñòàíöèîííûé, 1)"
p8 = "Áàðíàóëüñêàÿ òåïëîñåòåâàÿ êîìïàíèÿ ÎÀÎ (ã. Áàðíàóë, ïðîñïåêò Êîñìîíàâòîâ, 14æ (ÐÂÊ) ÁÒÖ)"
p9 = "Áàðíàóëüñêàÿ òåïëîñåòåâàÿ êîìïàíèÿ ÎÀÎ (ã. Áàðíàóë, ïðîñïåêò Êîñìîíàâòîâ, 14æ (ÐÂÊ) ÁÒÖ ÌÊÓ)"
p10 = "Áàðíàóëüñêàÿ ãåíåðàöèÿ ÎÀÎ (ã. Áàðíàóë, óë. Áðèëëèàíòîâàÿ, 2,ÒÝÖ-2)"
p11 = "Áàðíàóëüñêàÿ ÒÝÖ-3 ÎÀÎ (ã. Áàðíàóë, óë. Òðàêòîâàÿ, 7, ÒÝÖ-3)"
p12 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Âûïîëçîâî)"
p13 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ ã. Íîâîàëòàéñêà)"
p14 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Êîìñîìîëüñêàÿ)"
p15 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Êîñèõà)"
p16 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Ïåðâîìàéñêàÿ)"
p17 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Ñèáèðñêàÿ)"
p18 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ Òðîèöêîå)"
p19 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ-1 ã. Áàðíàóëà (2 áëîê)"
p21 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ-2 ã. Áàðíàóëà)"
p22 = "Íàñåëåíèå Àëòàéðåãèîíãàç (ÃÐÑ-3 ã. Áàðíàóëà)"
p23 = "Íàñåëåíèå Àëòàéðåãèîíãàç (Òàëüìåíêà (1 áëîê)"
p24 = "Íàñåëåíèå Àëòàéðåãèîíãàç (Òàëüìåíêà (2 áëîê)"
p25 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-2 ã. Áèéñêà)"
p26 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-3 ã. Áåëîêóðèõà)" '"Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ ã. Áåëîêóðèõà)"
p27 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-3 ã. Áèéñêà)"
p28 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-Àëòàéñêîå)"
p29 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-Ñìîëåíñêîå)"
p30 = "Íàñåëåíèå Àëòàéðåãèîíãàç ÎÎÎ (ÃÐÑ-Ñîâåòñêîå)"
p31 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (ÃÐÑ-2 ã.Áàðíàóë) (ã. Áàðíàóë, óë. Íîâîñèáèðñêàÿ, 44à)"
p32 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (ÊÁÊ): Çìåèíîãîðñêèé òðàêò, 112à"
p33 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (Þæíûé): ï. Þæíûé, Ëåñíîé òðàêò, 75"
p34 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (Øêîëà ñàäîâîäîâ): ã. Áàðíàóë, Çìåèíîãîðñêèé òðàêò, 120"
p35 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (Ãîíüáà): ï. Ãîíüáà, óë. Ñîâåòñêàÿ, 1à"
p36 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (Ëåáÿæüå): ñ. Ëåáÿæüå, óë. Øêîëüíàÿ, 65"
p37 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (ÊÊÇÎ): óë. 6-ÿ Íàãîðíàÿ, 11ã"
p38 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹1): óë. Ãîãîëÿ, 57à"
p39 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹2): óë. Èíòåðíàöèîíàëüíàÿ, 82à"
p40 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹4): óë. Îïûòíàÿ ñòàíöèÿ, 4á"
p41 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (ÀÊÈ): óë. Ïóøêèíà, 30"
p42 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹3): óë. ×êàëîâà, 247à"
p43 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹ 6): ã. Áàðíàóë, óë. Ãîãîëÿ, 16"
p45 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹7): ã. Áàðíàóë, óë. Àâàíåñîâà, 32"
p46 = "Ýíåðãåòèê ã. Áàðíàóëà ÌÓÏ (êîòåëüíàÿ ¹9): óë. Ãîãîëÿ, 22à"
p47 = "Áàðíàóëòðàíñìàø ÎÀÎ ÕÊ (ã. Áàðíàóë, ïðîñïåêò Êàëèíèíà, 28)"
p48 = "Ãîðíî-Àëòàéñêàÿ òåïëîâàÿ êîìïàíèÿ ÎÎÎ: ã. Ãîðíî-Àëòàéñê, óë. Êðàñíîàðìåéñêàÿ, 52"
tt = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_sut_ak", LookIn:=xlValues).Row, 1).Value
Workbooks.Open Filename:=tt
Sheets("Ñâîäêà çà ìåñÿö").Select
w_b = ActiveWorkbook.Name
w_s = ActiveSheet.Name
Workbooks(def_wb).Sheets(def_tab).Cells(37, 3).Value = izsvak(p1, w_b, w_s) 'âàãîí
Workbooks(def_wb).Sheets(def_tab).Cells(34, 3).Value = izsvak(p3, w_b, w_s) 'àøê
Workbooks(def_wb).Sheets(def_tab).Cells(35, 3).Value = izsvak(p4, w_b, w_s) 'èíä
Workbooks(def_wb).Sheets(def_tab).Cells(41, 3).Value = izsvak(p5, w_b, w_s) 'ìàë ðâê
'Workbooks(def_wb).Sheets(def_tab).Cells(33, 3).Value = izsvak(p8, w_b, w_s) 'ðâê
'Workbooks(def_wb).Sheets(def_tab).Cells(33, 3).Value = izsvak(p10, w_b, w_s) 'ò2
'Workbooks(def_wb).Sheets(def_tab).Cells(33, 3).Value = izsvak(p11, w_b, w_s) 'ò3
Workbooks(def_wb).Sheets(def_tab).Cells(39, 3).Value = izsvak(p12, w_b, w_s) + izsvak(p13, w_b, w_s) + izsvak(p14, w_b, w_s) + izsvak(p15, w_b, w_s) _
+ izsvak(p16, w_b, w_s) + izsvak(p17, w_b, w_s) + izsvak(p18, w_b, w_s) + izsvak(p19, w_b, w_s) + izsvak(p21, w_b, w_s) _
+ izsvak(p22, w_b, w_s) + izsvak(p23, w_b, w_s) + izsvak(p24, w_b, w_s) + izsvak(p25, w_b, w_s) + izsvak(p26, w_b, w_s) + izsvak(p27, w_b, w_s) _
+ izsvak(p28, w_b, w_s) + izsvak(p29, w_b, w_s) + izsvak(p30, w_b, w_s) 'íàñ
Workbooks(def_wb).Sheets(def_tab).Cells(36, 3).Value = izsvak(p31, w_b, w_s) + izsvak(p32, w_b, w_s) + izsvak(p33, w_b, w_s) + izsvak(p34, w_b, w_s) _
+ izsvak(p35, w_b, w_s) + izsvak(p36, w_b, w_s) + izsvak(p37, w_b, w_s) + izsvak(p38, w_b, w_s) + izsvak(p39, w_b, w_s) + izsvak(p40, w_b, w_s) _
+ izsvak(p41, w_b, w_s) + izsvak(p42, w_b, w_s) + izsvak(p43, w_b, w_s) + izsvak(p45, w_b, w_s) + izsvak(p46, w_b, w_s) 'ýíåðã
Workbooks(def_wb).Sheets(def_tab).Cells(38, 3).Value = izsvak(p47, w_b, w_s) 'áòø
Workbooks(w_b).Close False
tt = Workbooks(def_wb).Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_sut_ga", LookIn:=xlValues).Row, 1).Value
Workbooks.Open Filename:=tt
Sheets("Ñâîäêà çà ìåñÿö").Select
w_b = ActiveWorkbook.Name
w_s = ActiveSheet.Name
Workbooks(def_wb).Sheets(def_tab).Cells(40, 3).Value = izsvak(p48, w_b, w_s) 'ãàòê
Workbooks(w_b).Close False
Application.ScreenUpdating = True
End Sub
Function mail_(subjects As String, attach As String, title As String, body_ As String)
Dim OutlookApp As Object, SM As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set SM = OutlookApp.CreateItem(olMailItem)
SM.To = subjects
SM.Subject = title
SM.Body = body_ & Chr(13) & Chr(13) & "Ñ óâàæåíèåì, Äèñïåò÷åðñêàÿ ñëóæáà Àëòàéñêîãî êðàÿ!"
att = Split(attach, "|")
For Each item_ In att
SM.Attachments.Add item_
Next
On Error Resume Next
SM.Importance = 2
SM.Display
Set SM = Nothing
Set OutlookApp = Nothing
End Function
Private Sub ÎòêðûòüËîãè_Click()
ActiveWorkbook.Sheets("LOGS").Activate
End Sub
Private Sub Îòïðàâèòü4ÃÃÁ_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "Ôîðìà4ÃÃÁ"
End Sub
Private Sub Îòïðàâèòü4ÃÌÍ_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "Ôîðìà4ÃÌÍ"
End Sub
Private Sub ÎòïðàâèòüÏðîãíîç_Click()
defpath = "k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\ÏÐÎÃÍÎÇÛ\"
month_ = str_month(Month(Now() + 1), False, False, False) & "\"
month_n = str_month(Month(Now() + 1), False, True, True)
day_0 = Trim(str(Day(Now() - 1)))
day_ = Trim(str(Day(Now())))
day_1 = Trim(str(Day(Now() + 1)))
day_2 = Trim(str(Day(Now() + 2)))
If day_0 <= 9 Then
day_0 = "0" & day_0
End If
If day_ <= 9 Then
day_ = "0" & day_
End If
If day_1 <= 9 Then
day_1 = "0" & day_1
End If
If day_2 <= 9 Then
day_2 = "0" & day_2
End If
bef = defpath & month_ & "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_ & "-" & day_1 & " " & month_n & " " & Year(Now()) & ".xls"
af = defpath & month_ & "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_1 & "-" & day_2 & " " & month_n & " " & Year(Now()) & ".xls"
mail_ "dis@nrg.org.ru", defpath & month_ & "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_1 & "-" & day_2 & " " & month_n & " " & Year(Now() + 1) & ".xls", "Ïðîãíîç íà 2 ñóòîê Àëòàéñêèé êðàé, Ðåñïóáëèêà Àëòàé " & day_1 & "-" & day_2 & " " & month_n & " " & Year(Now() + 1) & "", ""
End Sub
Private Sub ÎòïðàâèòüÑâîäêó_Click()
On Error Resume Next
mon_ = get_month(Month(Now - 1), False, True, False)
'TaskID = Shell("k:\ÎÄÑ\Ñìåííûé Äèñïåò÷åð\ÐÀÁÎ×Àß\Åæåäíåâíûå\scripts\svodka.bat " & mon_ & " " & Year(Now()), vbMinimizedFocus)
TaskID = Shell("d:\Share\Special\svodka.bat " & mon_ & " " & Year(Now()), vbMinimizedFocus)
timer_second 6
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "ÑâîäêàEmail"
End Sub
Private Sub ÎòïðàâèòüÑóòêèÀËÏÓ_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "ÑóòêèÀËÏÓ"
End Sub
Private Sub ÎòïðàâèòüÑóòêèÃÃÁ_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "ÑóòêèÃÃÁ"
End Sub
Private Sub Îòïðàâèòü×àñîâûå_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "×àñîâûåEmail"
End Sub
Private Sub CommandButton2_Click()
Call Îòïðàâèòü×àñîâûå_Click
End Sub
Private Sub ïîëüçîâ1_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "Ïîëüçîâ1"
End Sub
Private Sub ïîëüçîâ2_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "Ïîëüçîâ2"
End Sub
Private Sub ïîëüçîâ3_Click()
On Error Resume Next
send_message "ÃðóïïàÐàññûëêè", "ÊîíòàêòûÀÐÃ", "Ïîëüçîâ3"
End Sub
Sub íàçíà÷èòü_âðåìÿ_Ùåëêíóòü()
Sheets("spisok_003").Cells(1, 2).Value = Sheets("spisok_003").Cells(Sheets("spisok_003").Cells(1, 1).Value + 1, 2).Value
Sheets("×ÀÑÎÂÛÅ").Cells(1, 2).Value = "Òåêóùèé èñïîëíèòåëü: " & Sheets("spisok_001").Cells(1, 2).Value
Sheets("×ÀÑÎÂÛÅ").Cells(2, 2).Value = "Íà âðåìÿ: " & Sheets("spisok_003").Cells(1, 2).Value
End Sub
Sub ñïèñîê_äèñïåò÷åðîâ_Èçìåíåíèå()
Sheets("spisok_001").Cells(1, 2).Value = Sheets("spisok_001").Cells(Sheets("spisok_001").Cells(1, 1).Value + 1, 2).Value
Sheets("spisok_001").Cells(1, 3).Value = Sheets("spisok_001").Cells(Sheets("spisok_001").Cells(1, 1).Value + 1, 3).Value
Sheets("spisok_001").Cells(1, 4).Value = Sheets("spisok_001").Cells(Sheets("spisok_001").Cells(1, 1).Value + 1, 4).Value
End Sub
Sub íàçíà÷èòü_äèñïåò÷åðà_Ùåëêíóòü()
Sheets("spisok_002").Cells(1, 1).Value = Day(Now)
Sheets("×ÀÑÎÂÛÅ").Cells(1, 2).Value = "Òåêóùèé èñïîëíèòåëü: " & Sheets("spisok_001").Cells(1, 2).Value
Sheets("×ÀÑÎÂÛÅ").Cells(2, 2).Value = "Íà âðåìÿ: " & Sheets("spisok_003").Cells(1, 2).Value
End Sub
Function timer_second(sec As Integer)
On Error Resume Next: Err.Clear
time_begin = Timer
time_end = Timer
While time_begin < time_end + (sec)
time_begin = Timer
Wend
End Function
Public Function get_month(Optional num_month As Integer = 1, Optional upcase As Boolean = False, Optional lowcase As Boolean = False, Optional tail As Boolean = False)
On Error Resume Next: Err.Clear
month_no_tail = Choose(num_month, "ßíâàðü", "Ôåâðàëü", "Ìàðò", "Àïðåëü", "Ìàé", "Èþíü", "Èþëü", "Àâãóñò", "Ñåíòÿáðü", "Îêòÿáðü", "Íîÿáðü", "Äåêàáðü")
month_tail = Choose(num_month, "ßíâàðÿ", "Ôåâðàëÿ", "Ìàðòà", "Àïðåëÿ", "Ìàÿ", "Èþíÿ", "Èþëÿ", "Àâãóñòà", "Ñåíòÿáðÿ", "Îêòÿáðÿ", "Íîÿáðÿ", "Äåêàáðÿ")
month_ = IIf(tail, month_tail, month_no_tail)
get_month = IIf(upcase, UCase(month_), IIf(lowcase, LCase(month_), month_))
End Function
Function write_contact_outlook_other(page_name)
End Function
Function write_contact_outlook_global(page_name)
End Function
Function CreateSheet(SheetName As String)
If SheetExists(SheetName) Then
CreateSheet = SheetName
Else
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = SheetName
End If
CreateSheet = SheetName
End Function
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function
Sub write_all_contact()
pagename = CreateSheet("ÊîíòàêòûÀÐÃ")
pagename1 = CreateSheet("ÃðóïïàÐàññûëêè")
ThisWorkbook.Worksheets(pagename1).Range("A1").Value = "ÈÌß"
ThisWorkbook.Worksheets(pagename1).Range("B1").Value = "ÇÀÃÎËÎÂÎÊ"
ThisWorkbook.Worksheets(pagename1).Range("C1").Value = "ÒÅÊÑÒ"
ThisWorkbook.Worksheets(pagename1).Range("D1").Value = "Ïóòü1"
ThisWorkbook.Worksheets(pagename1).Range("E1").Value = "Ïóòü2"
ThisWorkbook.Worksheets(pagename1).Range("F1").Value = "Ïóòü3"
ThisWorkbook.Worksheets(pagename1).Range("G1").Value = "Ïóòü4"
ThisWorkbook.Worksheets(pagename1).Range("H1").Value = "Ïóòü5"
ThisWorkbook.Worksheets(pagename1).Range("I1").Value = "Ïóòü6"
ThisWorkbook.Worksheets(pagename1).Range("J1").Value = "Ïóòü7"
ThisWorkbook.Worksheets(pagename1).Range("K1").Value = "Ïóòü8"
ThisWorkbook.Worksheets(pagename1).Range("L1").Value = "Ïóòü9"
ThisWorkbook.Worksheets(pagename1).Range("M1").Value = "Ïóòü10"
ThisWorkbook.Worksheets(pagename).Range("A1").Value = "ÔÈÎ"
ThisWorkbook.Worksheets(pagename).Range("B1").Value = "EMAIL"
ThisWorkbook.Worksheets(pagename).Range("C1").Value = "ÃÐÓÏÏÀ ÐÀÑÑÛËÊÈ"
write_contact_outlook_global pagename
write_contact_outlook_other pagename
End Sub
Function run_sh(path_, arr_param)
On Error Resume Next
param = ""
For Each one In arr_param
param = param & " " & one
Next one
Program = path_ & param
TaskID = Shell(Program, vbMinimizedFocus)
run_sh = True
End Function
Function send_message(sheet_group_send, sheet_cont_send, group_send)
On Error Resume Next
CountRow = ThisWorkbook.Worksheets(sheet_cont_send).Cells(Rows.Count, 1).End(xlUp).Row
mail_cont = ""
For i = 1 To CountRow
If ThisWorkbook.Worksheets(sheet_cont_send).Cells(i, 3).Value = group_send Then
mail_cont = mail_cont & ThisWorkbook.Worksheets(sheet_cont_send).Cells(i, 2).Value & "; "
End If
Next i
Set OutlookApp = CreateObject("Outlook.Application")
Set SM = OutlookApp.CreateItem(olMailItem)
SM.To = mail_cont
SM.Subject = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "B")
SM.HTMLBody = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "C")
Path_1 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "D")
Path_2 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "E")
Path_3 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "F")
Path_4 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "G")
Path_5 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "H")
Path_6 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "I")
Path_7 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "J")
Path_8 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "K")
Path_9 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "L")
Path_10 = find_cell(ThisWorkbook.Worksheets(sheet_group_send), CStr(group_send), True, "A", , "M")
If Path_1 <> "" Then: SM.Attachments.Add (Path_1)
If Path_2 <> "" Then: SM.Attachments.Add (Path_2)
If Path_3 <> "" Then: SM.Attachments.Add (Path_3)
If Path_4 <> "" Then: SM.Attachments.Add (Path_4)
If Path_5 <> "" Then: SM.Attachments.Add (Path_5)
If Path_6 <> "" Then: SM.Attachments.Add (Path_6)
If Path_7 <> "" Then: SM.Attachments.Add (Path_7)
If Path_8 <> "" Then: SM.Attachments.Add (Path_8)
If Path_9 <> "" Then: SM.Attachments.Add (Path_9)
If Path_10 <> "" Then: SM.Attachments.Add (Path_10)
SM.Importance = 2
SM.Display
Set SM = Nothing
Set OutlookApp = Nothing
End Function
Function find_cell(sheet_ As Variant, what_find As String, Optional value_ As Boolean = True, Optional find_col As String = "A", Optional find_row As Integer = 0, Optional ret_find_col As String = "A", Optional ret_find_row As Integer = 1)
'x = find_range(ThisWorkbook.Sheets("????1"), "17", True, "H", , "L")
'x1 = find_range(ThisWorkbook.Sheets("????1"), "1", True, , 14, , 24)
'xxx_next = sheet_.Cells(sheet_.Columns(where_find).Find(What:=what_find, After:=Cells(x1, "J"), SearchDirection:=xlNext).Row, ret_find_col).Value
On Error Resume Next: Err.Clear
If value_ Then
If find_col <> "" Then
find_cell = sheet_.Cells(sheet_.Columns(find_col).Find(What:=what_find, LookIn:=xlValues).Row, ret_find_col).Value
End If
If find_row <> 0 Then
find_cell = sheet_.Cells(ret_find_row, sheet_.Rows(find_row).Find(what_find, LookIn:=xlValues).Column).Value
End If
Else
If find_col <> "" Then
find_cell = sheet_.Columns(find_col).Find(What:=what_find, LookIn:=xlValues).Row
End If
If find_row <> 0 Then
find_cell = sheet_.Rows(find_row).Find(what_find, LookIn:=xlValues).Column
End If
End If
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment