Function getArea ByVal inp As String As String pos InStr inp val1 Righ

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
Function getArea(ByVal inp As String) As String
pos = InStr(inp, "(")
val1 = Right(inp, Len(inp) - pos)
Dim val2 As String
val2 = Left(val1, Len(val1) - 1)
getArea = val2
End Function
Function getProfession(ByVal name) As String
Set wsheet = Sheets("workerSheet")
getProfession = Application.VLookup(area, wsheet.Cells(1, 1).CurrentRegion, 2, False)
End Function
Function isFree(ByVal name As String, ByVal newId) As Boolean
Set workInfo = Sheets("workerSheet")
Set voyInfo = Sheets("informSheet")
Dim leave As Date
leave = Application.VLookup(newId, voyInfo.Cells(1, 1).CurrentRegion, 8, False)
period = Application.VLookup(newId, voyInfo.Cells(1, 1).CurrentRegion, 3, False)
leaveEnd = DateAdd("d", period, leave)
Dim startDate As Date
Dim maxSt As Date
Dim minEn As Date
posit = 1
For posit = 1 To workInfo.Cells(1, 1).CurrentRegion.Rows.Count
If workInfo.Cells(posit, 1) = name Then Exit For
Next posit
Dim addit As Double
isOk = True
If workInfo.Cells(posit, 3) = 0 Then
isFree = True
Else
voyId = 0
For i = 4 To workInfo.Cells(posit, 3) + 3
voyId = workInfo.Cells(posit, i)
startDate = Application.VLookup(voyId, voyInfo.Cells(1, 1).CurrentRegion, 8, False)
addit = CDbl(Application.VLookup(voyId, voyInfo.Cells(1, 1).CurrentRegion, 3, False))
endDate = DateAdd("d", addit, startDate)
maxSt = WorksheetFunction.Max(startDate, leave)
minEn = WorksheetFunction.Min(endDate, leaveEnd)
If maxSt <= minEn Then isOk = False
Next i
End If
isFree = isOk
End Function
Sub checkDatesAndWrite(ByVal name As String)
Set wsheet = Sheets("workerSheet")
Line = 1
For Line = 1 To wsheet.Cells(1, 1).CurrentRegion.Rows.Count
If wsheet.Cells(Line, 1) = name Then Exit For
Next
Set datas = Sheets("Êòî åäåò")
datas.Cells(1, 16) = "Ôàìèëèÿ ñîòðóäíèêà"
datas.Cells(2, 16) = name
datas.Cells(1, 1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=datas.Range(datas.Cells(1, 16), datas.Cells(2, 16)), CopyToRange:=datas.Range(datas.Cells(1, 18), datas.Cells(1, 18)), Unique:=False
OFFSET_DECLINE = 50
wsheet.Cells(Line, OFFSET_DECLINE) = 0
voyCount = datas.Cells(1, 18).CurrentRegion.Rows.Count
For i = 2 To voyCount
currCount = wsheet.Cells(Line, 3)
If isFree(name, datas.Cells(i, 18)) = True Then
currCount = currCount + 1
wsheet.Cells(Line, 3) = currCount
wsheet.Cells(Line, 3 + currCount) = datas.Cells(i, 18)
Else
currCount = wsheet.Cells(Line, OFFSET_DECLINE)
wsheet.Cells(Line, OFFSET_DECLINE) = currCount + 1
wsheet.Cells(Line, currCount + OFFSET_DECLINE + 1) = datas.Cells(i, 18)
End If
Next i
datas.Cells(1, 18).CurrentRegion.Clear
End Sub
Sub generateVoyg(id, posit)
Set dataSheet = ActiveWorkbook.Sheets("Êîìàíäèðîâêè")
Set informSheet = ActiveWorkbook.Sheets("informSheet")
Set targetSheet = ActiveWorkbook.Sheets("Ñïèñîê öåëåé")
Set inCountrySheet = ActiveWorkbook.Sheets("Ñïèñîê îáëàñòåé")
Set outCountrySheet = ActiveWorkbook.Sheets("Ñïèñîê ñòðàí")
dataCount = dataSheet.Cells(1, 1).CurrentRegion.Rows.Count
typesCount = targetSheet.Cells(1, 1).CurrentRegion.Rows.Count
Dim voyType As Variant
Dim voyDate
Dim voyTime
Dim voyPlace
Dim voyPrice
Dim voyPriceId
For i = 2 To dataCount
If dataSheet.Cells(i, 1) = id Then
voyType = dataSheet.Cells(i, 4)
voyDate = dataSheet.Cells(i, 2)
voyTime = dataSheet.Cells(i, 3)
voyPlace = dataSheet.Cells(i, 5)
voyPrice = dataSheet.Cells(i, 6)
voyPriceId = dataSheet.Cells(i, 7)
Exit For
End If
Next
' Correct dates
Set Rng = targetSheet.Range(targetSheet.Cells(1, 1), targetSheet.Cells(typesCount, 2))
Dim maxDays As Variant
maxDays = Application.VLookup(voyType, Rng, 2, False)
If IsError(maxDays) Then maxDays = 10000000
isCorrected = False
If voyTime > maxDays Then
voyTime = maxDays
isCorrected = True
End If
'''''''''''''''''''
'''' Find location
Rng = outCountrySheet.Cells(1, 1).CurrentRegion
area = getArea(voyPlace)
translatorIsNeeded = False
perDay = 0
transfer = 0
If IsError(Application.VLookup(area, Rng, 3, False)) = False Then
translatorIsNeeded = True
perDay = Application.VLookup(area, Rng, 2, False)
transfer = Application.VLookup(area, Rng, 3, False)
Else
Rng = inCountrySheet.Cells(1, 1).CurrentRegion
perDay = Application.VLookup(area, Rng, 2, False)
If IsError(perDay) Or perDay = Empty Then perDay = 1500
transfer = Application.VLookup(area, Rng, 3, False)
End If
informSheet.Cells(posit, 1) = id
informSheet.Cells(posit, 2) = isCorrected
informSheet.Cells(posit, 3) = voyTime
informSheet.Cells(posit, 4) = voyPlace
informSheet.Cells(posit, 5) = perDay
informSheet.Cells(posit, 6) = transfer
informSheet.Cells(posit, 7) = voyType
informSheet.Cells(posit, 8) = voyDate
End Sub
Sub fillWorkersOnVoyage()
Set informSheet = ActiveWorkbook.Sheets("informSheet")
Set src = Sheets("Êòî åäåò")
End Sub
'voyPlace = dataSheet.VLookup(id, dataSheet(1, 1), 5, False)
Private Sub UserForm_Activate()
Set cWorkbook = ActiveWorkbook
Set work = Sheets("Êîìàíäèðîâêè")
Set firstZao = Sheets(4)
Set secondZao = Sheets(5)
Set inviteZao = Sheets(6)
rowsCount = work.Cells(1, 1).CurrentRegion.Rows.Count
Dim additionLine As String
Set workerInfo = cWorkbook.Sheets.Add
workerInfo.name = "workerSheet"
Set bufferInfo = cWorkbook.Sheets.Add
bufferInfo.name = "informSheet"
For i = 2 To rowsCount
generateVoyg work.Cells(i, 1), i - 1
Next
countWorkers = 1
For i = 1 To firstZao.Cells(1, 1).CurrentRegion.Rows.Count
workerInfo.Cells(countWorkers, 1) = firstZao.Cells(i, 1)
workerInfo.Cells(countWorkers, 2) = firstZao.Cells(i, 4)
workerInfo.Cells(countWorkers, 3) = 0
countWorkers = countWorkers + 1
Next i
For i = 1 To secondZao.Cells(1, 1).CurrentRegion.Rows.Count
workerInfo.Cells(countWorkers, 1) = secondZao.Cells(i, 1)
workerInfo.Cells(countWorkers, 2) = secondZao.Cells(i, 4)
workerInfo.Cells(countWorkers, 3) = 0
countWorkers = countWorkers + 1
Next i
For i = 1 To inviteZao.Cells(1, 1).CurrentRegion.Rows.Count
workerInfo.Cells(countWorkers, 1) = inviteZao.Cells(i, 1)
workerInfo.Cells(countWorkers, 2) = inviteZao.Cells(i, 2)
workerInfo.Cells(countWorkers, 3) = 0
countWorkers = countWorkers + 1
Next i
For i = 2 To countWorkers
checkDatesAndWrite workerInfo.Cells(i, 1)
Next
For i = 2 To rowsCount
If i = bufferInfo.Columns.Count Then bufferInfo.Columns(i).Insert Shift:=xlToRight
additionLine = work.Cells(i, 1)
generateVoyg work.Cells(i, 1), i - 1
additionLine = additionLine + " " + work.Cells(i, 4) + " " + work.Cells(i, 5)
ListBox1.AddItem additionLine
Next
End Sub