Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Sub Поместить_текущий_лист_в_архив()
SheetsCount = ActiveWorkbook.Sheets.Count
NameSheet = ActiveSheet.Name
SheetsIndex = ActiveSheet.Index + 1
ActiveSheet.Unprotect Password:="123"
'Range("I1").FormulaR1C1 = "=RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1]"
Range("I1").FormulaR1C1 = "=IFERROR(RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1],""--проблемные данные--"")"
Range("I1").Select
Selection.AutoFill Destination:=Range("I1:I30"), Type:=xlFillDefault
Range("I1:I50").Select
Sheets("Архив").Unprotect Password:="123"
Sheets("Архив").Select
ExcelLastRow = Sheets("Архив").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Numerator = ExcelLastRow
For i = 1 To 50
ValueI = Sheets(NameSheet).Range("I" & i).Value
If ValueI <> "" Then
Numerator = Numerator + 1
Sheets(NameSheet).Range("A" & i & ":H" & i).Copy
Sheets("Архив").Range("A" & Numerator).Select
ActiveSheet.Paste
Sheets("Архив").Range("A" & Numerator).Select
End If
Next
Sheets("Архив").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.DisplayAlerts = False
If SheetsIndex <= SheetsCount Then
Sheets(SheetsIndex).Activate
Else
Sheets(SheetsCount - 1).Activate
End If
Sheets(NameSheet).Delete
Application.DisplayAlerts = True
End Sub
Sub Разблокировать_текущий_лист()
ActiveSheet.Unprotect Password:="123"
End Sub
Sub Заблокировать_текущий_лист()
ActiveSheet.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub auto_open()
Application.DisplayAlerts = False
Flag_ = False
DataTxt = CStr(Now)
DataTxt = Mid(DataTxt, 1, 6) + Mid(DataTxt, 9, 2)
DataTxt2 = CStr(Date + 1)
DataTxt2 = Mid(DataTxt2, 1, 6) + Mid(DataTxt2, 9, 2)
'MsgBox DataTxt2
Проверка_Время = Hour(Time) >= 18
For Each list_ In ThisWorkbook.Worksheets
Проверка_Даты_На_Завтра = list_.Name = DataTxt2
'MsgBox Проверка_Даты_На_Завтра
Проверка_На_Завтра = Проверка_Даты_На_Завтра And Проверка_Время
'MsgBox Проверка_На_Завтра
Проверка_Уже_Сегодня = list_.Name = DataTxt
'MsgBox DataTxt
Блокируем_Лист = Проверка_На_Завтра Or Проверка_Уже_Сегодня
'MsgBox Блокируем_Лист
If Блокируем_Лист Then
If Not list_.ProtectContents Then
list_.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
Flag_ = True
End If
End If
Next
Sheets("Архив").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
If Flag_ Then
ThisWorkbook.Save 'SaveChanges:=True
End If
Application.DisplayAlerts = True
End Sub
Sub Регсчетчика1_Изменение()
On Error GoTo Metka1
Range("C1").FormulaR1C1 = "=RC[10]+41608"
Txt = Range("C1").Text
Range("C1").FormulaR1C1 = Txt
If ActiveSheet.Name <> "Бланк" Then
ActiveSheet.Name = Mid(Txt, 1, 6) + Mid(Txt, 9, 2)
End If
GoTo Ends:
Metka1:
MsgBox "Такой лист уже есть!"
Ends:
End Sub
Sub Пятно11_Щелчок()
КоличествоЛистов = ThisWorkbook.Worksheets.Count
День = ActiveSheet.Range("M1").Value + 1
If ActiveSheet.Name <> "Бланк" Then
Sheets("Бланк").Copy After:=Sheets(КоличествоЛистов)
End If
Sheets(КоличествоЛистов + 1).Visible = True
Sheets(КоличествоЛистов + 1).Select
Range("M1").FormulaR1C1 = День
With ActiveWorkbook.Sheets(КоличествоЛистов + 1).Tab
.ColorIndex = xlColorIndexNone
.TintAndShade = 0
End With
On Error GoTo Metka1
Range("C1").FormulaR1C1 = "=RC[10]+41608"
Txt = Range("C1").Text
Range("C1").FormulaR1C1 = Txt
If ActiveSheet.Name <> "Бланк" Then
ActiveSheet.Name = Mid(Txt, 1, 6) + Mid(Txt, 9, 2)
End If
GoTo Ends:
Metka1:
MsgBox "Такой лист уже есть!"
Ends:
End Sub
Sub ЗагрузитьДанныеИзСтарогоФайла()
f = 1
If f <> 1 Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ChDir "\\ftp\Exchange\xls"
Workbooks.Open Filename:="\\ftp\Exchange\xls\Водители.xlsx", ReadOnly:=True
i = 0
For Each list_ In ActiveWorkbook.Sheets
list_.Select
list_.Rows("1:30").Select
Selection.Copy
Windows("!Водители.xlsm").Activate
Sheets("Архив").Select
Range("A" + CStr(i * 30 + 1)).Select
ActiveSheet.Paste
i = i + 1
Windows("..Водители.xlsx").Activate
Next
ActiveWindow.Close SaveChanges:=False
ActiveWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub
Sub Макрос2()
Application.DisplayAlerts = False
Flag_ = False
DataTxt = CStr(Now)
DataTxt = Mid(DataTxt, 1, 6) + Mid(DataTxt, 9, 2)
For Each list_ In ThisWorkbook.Worksheets
If list_.Name = DataTxt Then
If Hour(Time) >= 15 Then
If Not list_.ProtectContents Then
list_.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
Flag_ = True
End If
End If
End If
Next
If Flag_ Then
ThisWorkbook.Save 'SaveChanges:=True
End If
Application.DisplayAlerts = True
End Sub
Sub Макрос3()
'
' Макрос3 Макрос
'
'
Sheets("Лист1").Select
ActiveSheet.Unprotect
Range("B6").Select
End Sub |