Sub ЗаполнениеСменами()
'aequit 03.03.2020 v.3
Dim b As Long, d As Long, i As Long, h1 As Long, h2 As Long, v As Long, k As Long, g As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
d = Worksheets("conf").Range("B4") + 5
b = 6
Do While Range("AL" & b).HasFormula
b = b + 1
Loop
For g = 6 To b
h1 = 0
h2 = 0
For i = 6 To d
If Cells(g, i) <> Empty And Cells(g, i + 1) <> Empty Then
If h1 = 0 Then h1 = i
If h1 > 0 And h1 <> i And h2 = 0 Then
h2 = i
v = h2 - h1
k = i
End If
Else
If h1 > 0 And h2 > 0 And i = k + v Then
Cells(g, i) = Cells(g, h1)
If i < d Then
Cells(g, i + 1) = Cells(g, h1 + 1)
End If
k = i
End If
End If
Next i
Next g
Select Case Worksheets("conf").Range("B4")
Case Is = 30
Range(Cells(6, d + 1), Cells(b - 1, d + 1)).ClearContents
Case Is = 29
Range(Cells(6, d + 1), Cells(b - 1, d + 2)).ClearContents
Case Is = 28
Range(Cells(6, d + 1), Cells(b - 1, d + 3)).ClearContents
End Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub ЗаполнениеСменамиПоОдной()
'aequit 03.03.2020
Dim b As Long, d As Long, i As Long, h1 As Long, h2 As Long, v As Long, k As Long, g As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
d = Worksheets("conf").Range("B4") + 5
b = 6
Do While Range("AL" & b).HasFormula
b = b + 1
Loop
For g = 6 To b
h1 = 0
h2 = 0
For i = 6 To d
If Cells(g, i) <> Empty And Cells(g, i + 1) <> Empty Then
h1 = i
k = i + 4
Else
If h1 > 0 And i = k Then
Cells(g, i) = Cells(g, h1)
If i < d Then
Cells(g, i + 1) = Cells(g, h1 + 1)
End If
k = i + 4
End If
End If
Next i
Next g
If Worksheets("conf").Range("B4") < 31 Then
Range(Cells(6, d + 1), Cells(b - 1, d + 1)).ClearContents
End If
Select Case Worksheets("conf").Range("B4")
Case Is = 30
Range(Cells(6, d + 1), Cells(b - 1, d + 1)).ClearContents
Case Is = 29
Range(Cells(6, d + 1), Cells(b - 1, d + 2)).ClearContents
Case Is = 28
Range(Cells(6, d + 1), Cells(b - 1, d + 3)).ClearContents
End Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub ЗаполнениеВосьмерками()
'aequit 03.03.2020
Dim b As Long, d As Long, i As Long, g As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim wsC As Worksheet
Set wsC = Worksheets("conf")
d = wsC.Range("B4") + 5
b = 6
Do While Range("AL" & b).HasFormula
b = b + 1
Loop
For g = 6 To b
For i = 6 To d
If Weekday(DateSerial(wsC.Range("D2"), wsC.Range("A3"), Cells(5, i)), 2) < 6 Then
Cells(g, i) = 8
Else
Cells(g, i) = Empty
End If
Next i
Next g
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
|