Skip to content

Commit 2cef5ea

Browse files
dievdiev
committed
Final version for other users
1 parent d8fef92 commit 2cef5ea

File tree

1 file changed

+132
-80
lines changed

1 file changed

+132
-80
lines changed

‎Turniket/Turniket.bas

+132-80
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
1-
'(c) Дмитрий Евдокимов, ред. 01.02.2017
1+
Attribute VB_Name = "Turniket"
2+
'(c) Дмитрий Евдокимов, ред. 27.09.2017
23

34
' Исходные данные:
45
' 1) Этот XLSM-файл с модулем Turniket.bas;
56
' 2) XLS или CSV-файл с турникетов;
67
' 3) TXT-файл с парковки;
7-
' 4) Присвоить нужный период с Date1 по Date2 ниже.
88
'
99
' Убеждаемся, что есть лист "Отчет" (он будет очищен), а листы "Парковка" и "Турникет" будут удалены и загружены снова
1010
' Меню "Разработчик" - "Макросы" - выбираем единственный макрос TurnOver - "Выполнить" - ждем
@@ -18,8 +18,12 @@ Option Explicit
1818
Option Compare Text
1919

2020
'Фильтр с Date1 по Date2
21-
Const Date1 As Date = #5/1/2017# 'mm/dd/yyyy
22-
Const Date2 As Date = #5/31/2017# 'mm/dd/yyyy
21+
'Const Date1 As Date = #9/1/2017# 'mm/dd/yyyy
22+
'Const Date2 As Date = #9/30/2017# 'mm/dd/yyyy
23+
Dim Date1 As Date
24+
Dim Date2 As Date
25+
26+
Const AppTitle As String = "Турникет"
2327

2428
'Столбцы с турникета
2529
Const TURNIKET As String = "Турникет"
@@ -49,10 +53,13 @@ Const ColRTotal As Long = 9
4953

5054
Sub TurnOver()
5155
Dim SheetFile As Variant
52-
Dim WB As String
56+
57+
Dim Book1 As Workbook
58+
Dim Book2 As Workbook
5359

5460
Dim Sheet1 As Worksheet
5561
Dim Sheet2 As Worksheet
62+
5663
Dim Row1 As Long
5764
Dim Row2 As Long
5865

@@ -66,9 +73,24 @@ Sub TurnOver()
6673
Dim nMins As Long
6774
Dim i As Long
6875

76+
Dim Answer As Variant
77+
On Error GoTo DateError
78+
79+
Answer = "01." & Format(DateAdd("m", -1, Now), "MM.yyyy")
80+
Answer = InputBox("Дата начала периода:", "Турникет", Answer)
81+
If Answer = "" Then Exit Sub
82+
Date1 = CDate(Answer)
83+
84+
Answer = Format(DateAdd("d", -1, DateAdd("m", 1, Date1)), "dd.MM.yyyy")
85+
Answer = InputBox("Дата конца периода:", "Турникет", Answer)
86+
If Answer = "" Then Exit Sub
87+
Date2 = CDate(Answer)
88+
89+
On Error GoTo SomeError
90+
6991
'Очистка отчета
7092
Application.DisplayStatusBar = True
71-
WB = ActiveWorkbook.Name
93+
Set Book2 = ActiveWorkbook
7294
Set Sheet2 = ActiveWorkbook.Worksheets(REPORT)
7395
Sheet2.Cells.Delete
7496
Row2 = 1
@@ -78,15 +100,18 @@ Step1:
78100

79101
'Ищем данные с турникета
80102
Application.StatusBar = "Загрузка данных с турникета..."
81-
ChDir CurDir
103+
ChDrive ActiveWorkbook.Path
104+
ChDir ActiveWorkbook.Path 'CurDir
82105
SheetFile = Application.GetOpenFilename("Excel (*.xls;*.csv), *.xls;*.csv", , "Данные с турникета (файл Excel)")
83-
If SheetFile = False Then GoTo Step2
106+
If SheetFile = False Then GoTo CancelError 'Step2
84107

108+
MsgBox "Сейчас будет запрос на удаление старых данных - удалите их все, чтобы загрузить заново.", vbInformation, AppTitle
85109
For Each Sheet1 In Sheets
86110
If Sheet1.Name = TURNIKET Then Sheet1.Delete
87111
Next
88112

89113
Workbooks.Open Filename:=SheetFile
114+
Set Book1 = ActiveWorkbook
90115

91116
If LCase(Right(SheetFile, 4)) = ".csv" Then
92117
Columns("A:A").Select
@@ -98,10 +123,14 @@ Step1:
98123
End If
99124

100125
Sheets(1).Select
101-
Sheets(1).Copy Before:=Workbooks(WB).Sheets(1)
102-
Workbooks(WB).Activate
126+
Sheets(1).Copy Before:=Book2.Sheets(1)
127+
128+
Book2.Activate
103129
Sheets(1).Select
104130
Sheets(1).Name = TURNIKET
131+
132+
Book1.Close SaveChanges:=False
133+
Set Book1 = Nothing
105134

106135
TurniketLoaded:
107136
Set Sheet1 = ActiveWorkbook.Worksheets(TURNIKET)
@@ -145,7 +174,7 @@ Step2:
145174
'Ищем данные с парковки
146175
Application.StatusBar = "Загрузка данных с парковки..."
147176
SheetFile = Application.GetOpenFilename("Text (*.txt), *.txt", , "Данные с парковки (текстовый файл)")
148-
If SheetFile = False Then GoTo Step3
177+
If SheetFile = False Then GoTo CancelError 'Step3
149178

150179
For Each Sheet1 In Sheets
151180
If Sheet1.Name = PARKING Then Sheet1.Delete
@@ -156,11 +185,18 @@ Step2:
156185
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
157186
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
158187
Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
188+
Set Book1 = ActiveWorkbook
189+
159190
Sheets(1).Select
160-
Sheets(1).Copy Before:=Workbooks(WB).Sheets(1)
191+
Sheets(1).Copy Before:=Book2.Sheets(1)
192+
193+
Book2.Activate
161194
Sheets(1).Select
162195
Sheets(1).Name = PARKING
163196

197+
Book1.Close SaveChanges:=False
198+
Set Book1 = Nothing
199+
164200
ParkingLoaded:
165201
Set Sheet1 = ActiveWorkbook.Worksheets(PARKING)
166202
Sheet1.Columns("A:D").AutoFit
@@ -197,10 +233,10 @@ ParkingLoaded:
197233
Step3:
198234
'Сортируем
199235
Application.StatusBar = "Сортировка по времени... "
200-
Sheet2.Sort.SortFields.Clear
201-
Sheet2.Sort.SortFields.Add Key:=Range("C1"), _
202-
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
203-
With ActiveWorkbook.Worksheets("Отчет").Sort
236+
With Sheet2.Sort
237+
.SortFields.Clear
238+
.SortFields.Add Key:=Range("C1"), _
239+
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
204240
.SetRange Range("A1:D" & Row2 - 1)
205241
.Header = xlNo
206242
.MatchCase = False
@@ -214,84 +250,102 @@ Step3:
214250
Row1 = 1
215251

216252
SName = ""
217-
Do While Len(Sheet2.Cells(Row1, ColRName).Text) > 0
218-
SDate = Sheet2.Cells(Row1, ColRDate)
219-
If SName <> Sheet2.Cells(Row1, ColRName).Text Then
220-
SName = Sheet2.Cells(Row1, ColRName).Text
221-
Application.StatusBar = "Поиск времени ухода... " & SDate & " " & SName
222-
Sheet2.Cells(Row1, ColRName).Select
223-
DoEvents
224-
End If
225-
'If Left(SName, ColRName) <> "-" Then
226-
Row2 = Row1 + 1
227-
Do While Sheet2.Cells(Row2, ColRDate).Text = SDate
228-
If Sheet2.Cells(Row2, ColRName).Text = SName Then
229-
Sheet2.Cells(Row1, ColRLogout).FormulaR1C1 = Sheet2.Cells(Row2, ColRLogin)
230-
Sheet2.Cells(Row1, ColRObjout) = Sheet2.Cells(Row2, ColRObjin)
231-
nMins = DateDiff("n", Sheet2.Cells(Row1, ColRLogin), Sheet2.Cells(Row1, ColRLogout)) - 48 'Обед 48 минут
232-
If nMins > 0 Then
233-
Sheet2.Cells(Row1, ColRHours).FormulaR1C1 = "=RC[-2]-RC[-4]-48/60/24" ' = nMins
234-
Sheet2.Cells(Row1, ColRMins) = nMins
235-
Sheet2.Cells(Row1, ColRTotal).FormulaR1C1 = "=RC[-1]/60" ' = nMins \ 60
253+
With Sheet2
254+
Do While Len(.Cells(Row1, ColRName).Text) > 0
255+
SDate = .Cells(Row1, ColRDate)
256+
If SName <> .Cells(Row1, ColRName).Text Then
257+
SName = .Cells(Row1, ColRName).Text
258+
Application.StatusBar = "Поиск времени ухода... " & SDate & " " & SName
259+
.Cells(Row1, ColRName).Select
260+
DoEvents
261+
End If
262+
'If Left(SName, ColRName) <> "-" Then
263+
Row2 = Row1 + 1
264+
Do While .Cells(Row2, ColRDate).Text = SDate
265+
If .Cells(Row2, ColRName).Text = SName Then
266+
.Cells(Row1, ColRLogout).FormulaR1C1 = .Cells(Row2, ColRLogin)
267+
.Cells(Row1, ColRObjout) = .Cells(Row2, ColRObjin)
268+
nMins = DateDiff("n", .Cells(Row1, ColRLogin), .Cells(Row1, ColRLogout)) - 48 'Обед 48 минут
269+
If nMins > 0 Then
270+
.Cells(Row1, ColRHours).FormulaR1C1 = "=RC[-2]-RC[-4]-48/60/24" ' = nMins
271+
.Cells(Row1, ColRMins) = nMins
272+
.Cells(Row1, ColRTotal).FormulaR1C1 = "=RC[-1]/60" ' = nMins \ 60
273+
End If
274+
.Rows(Row2).Delete
275+
Else
276+
Row2 = Row2 + 1
236277
End If
237-
'Sheet2.Cells(Row2, ColRName) = "-" & Sheet2.Cells(Row2, 1).Text
238-
Sheet2.Rows(Row2).Delete
239-
Else
240-
Row2 = Row2 + 1
241-
End If
242-
Loop
243-
'End If
244-
Row1 = Row1 + 1
245-
Loop
278+
Loop
279+
'End If
280+
Row1 = Row1 + 1
281+
Loop
282+
End With
246283

247284
'Финальная красота
248285
Application.StatusBar = "Сортировка по ФИО... "
249286
Row1 = Row1 - 1
250-
Sheet2.Sort.SortFields.Clear
251-
Sheet2.Sort.SortFields.Add Key:=Range( _
252-
"A1:A" & Row1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
253-
xlSortNormal
254-
Sheet2.Sort.SortFields.Add Key:=Range( _
255-
"B1:B" & Row1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
256-
xlSortNormal
257287
With Sheet2.Sort
288+
.SortFields.Clear
289+
.SortFields.Add Key:=Range( _
290+
"A1:A" & Row1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
291+
xlSortNormal
292+
.SortFields.Add Key:=Range( _
293+
"B1:B" & Row1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
294+
xlSortNormal
258295
.SetRange Range("A1:I" & Row1)
259-
'.Header = xlYes
260296
.Header = xlNo
261297
.MatchCase = False
262298
.Orientation = xlTopToBottom
263299
.SortMethod = xlPinYin
264300
.Apply
265301
End With
266302

267-
Sheet2.Rows(1).Insert
268-
Row2 = 1
269-
Sheet2.Cells(Row2, ColRName) = "ФИО" 'A
270-
Sheet2.Cells(Row2, ColRDate) = "Дата" 'B
271-
Sheet2.Cells(Row2, ColRLogin) = "Приход" 'C
272-
Sheet2.Cells(Row2, ColRObjin) = "Вход" 'D
273-
Sheet2.Cells(Row2, ColRLogout) = "Уход" 'E
274-
Sheet2.Cells(Row2, ColRObjout) = "Выход" 'F
275-
Sheet2.Cells(Row2, ColRHours) = "Часы" 'G
276-
Sheet2.Cells(Row2, ColRMins) = "Минуты" 'H
277-
Sheet2.Cells(Row2, ColRTotal) = "Дробь" 'I
278-
279-
Sheet2.Rows(Row2).Font.Bold = True
280-
Sheet2.Columns(ColRName).NumberFormat = "@"
281-
Sheet2.Columns(ColRLogin).NumberFormat = "h:mm;@"
282-
Sheet2.Cells(Row2, ColRObjin).NumberFormat = "@"
283-
Sheet2.Columns(ColRLogout).NumberFormat = "h:mm;@"
284-
Sheet2.Cells(Row2, ColRObjout).NumberFormat = "@"
285-
Sheet2.Columns(ColRHours).NumberFormat = "h:mm;@"
286-
Sheet2.Columns(ColRMins).NumberFormat = "0"
287-
Sheet2.Columns(ColRTotal).NumberFormat = "0.00"
288-
Sheet2.Columns("A:I").EntireColumn.AutoFit
289-
290-
'Sheet2.Cells("A2").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5), _
291-
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
292-
'Sheet2.Outline.ShowLevels RowLevels:=2
303+
With Sheet2
304+
.Rows(1).Insert
305+
Row2 = 1
306+
.Cells(Row2, ColRName) = "ФИО" 'A
307+
.Cells(Row2, ColRDate) = "Дата" 'B
308+
.Cells(Row2, ColRLogin) = "Приход" 'C
309+
.Cells(Row2, ColRObjin) = "Вход" 'D
310+
.Cells(Row2, ColRLogout) = "Уход" 'E
311+
.Cells(Row2, ColRObjout) = "Выход" 'F
312+
.Cells(Row2, ColRHours) = "Часы" 'G
313+
.Cells(Row2, ColRMins) = "Минуты" 'H
314+
.Cells(Row2, ColRTotal) = "Дробь" 'I
315+
316+
.Rows(Row2).Font.Bold = True
317+
.Columns(ColRName).NumberFormat = "@"
318+
.Columns(ColRLogin).NumberFormat = "h:mm;@"
319+
.Cells(Row2, ColRObjin).NumberFormat = "@"
320+
.Columns(ColRLogout).NumberFormat = "h:mm;@"
321+
.Cells(Row2, ColRObjout).NumberFormat = "@"
322+
.Columns(ColRHours).NumberFormat = "h:mm;@"
323+
.Columns(ColRMins).NumberFormat = "0"
324+
.Columns(ColRTotal).NumberFormat = "0.00"
325+
.Columns("A:I").EntireColumn.AutoFit
326+
327+
.Cells(2, 1).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(9), _
328+
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
329+
.Outline.ShowLevels RowLevels:=2
330+
End With
331+
332+
MsgBox "Расчет окончен.", vbInformation, AppTitle
293333

334+
ExitSub:
294335
Application.StatusBar = False
336+
Exit Sub
337+
338+
CancelError:
339+
MsgBox "Отказ от ввода данных.", vbExclamation, AppTitle
340+
GoTo ExitSub
341+
342+
DateError:
343+
MsgBox "Ошибка ввода даты.", vbCritical, AppTitle
344+
GoTo ExitSub
345+
346+
SomeError:
347+
MsgBox "Произошла какая-то ошибка в программе.", vbCritical, AppTitle
348+
GoTo ExitSub
295349
End Sub
296350

297351
Function FIO(S As String)
@@ -301,8 +355,6 @@ Function FIO(S As String)
301355
If UBound(A) = 2 Then
302356
FIO = A(0) & " " & Left(A(1), 1) & "." & Left(A(2), 1) & "."
303357
Else
304-
'MsgBox ("Ошибка в ФИО с парковки")
305-
'Stop
306358
FIO = S
307359
End If
308360
End Function

0 commit comments

Comments
 (0)