Доброе утро, уважаемые форумчане!
в примере необходимо добавить не достающих дат, и добавить табель.
Есть макрос с добавлением дат, но он работает только по одному сотруднику.
Как исправить по кодам макроса чтобы добавили дату всех сотрудников.
в примере необходимо добавить не достающих дат, и добавить табель.
Есть макрос с добавлением дат, но он работает только по одному сотруднику.
Как исправить по кодам макроса чтобы добавили дату всех сотрудников.
| Код |
|---|
Sub MyDateAdd()
Dim Sh, FUN As Object
Dim MyRange As Range
Dim MyCol, FirstRow, i, MaxDays, MyMonth, MyYear As Long
Dim TempDate As Date
Set FUN = Application.WorksheetFunction
Set MyRange = Application.InputBox("Выделите таблицу для обработки польностью", Type:=8)
Set Sh = MyRange.Parent
FirstRow = MyRange.Row + 1
MyCol = MyRange.Column
MyMonth = Month(Sh.Cells(FirstRow, MyCol).Value)
MyYear = Year(Sh.Cells(FirstRow, MyCol).Value)
MaxDays = Day(FUN.EoMonth(FUN.Max(MyRange.Columns(1)), 0))
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
i = 1
Do While i <= MaxDays
TempDate = DateSerial(MyYear, MyMonth, i)
If Sh.Cells(i + 1, MyCol).Value <> TempDate Then
Sh.Rows(i + 1).Insert
Sh.Cells(i + 1, MyCol).Value = TempDate
i = i + 1
Else
i = i + 1
End If
Loop
Sh.Range(Sh.Cells(FirstRow, MyCol + 1), Sh.Cells(FirstRow, MyRange.Columns.Count)).NumberFormat = "[h]:mm:ss"
Sh.Range(Sh.Cells(FirstRow, MyCol), Sh.Cells(FirstRow, MyRange.Columns.Count)).Copy
Sh.Range(Sh.Cells(FirstRow, MyCol), Sh.Cells(MaxDays + 1, MyRange.Columns.Count)).PasteSpecial xlPasteFormats
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub |
Изменено: - 28.11.2013 14:29:28
