Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 2cef5ea

Browse files
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‎

Lines changed: 132 additions & 80 deletions
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+
WithSheet2.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)

AltStyle によって変換されたページ (->オリジナル) /