Sub edit_work_data Копирование таблицы Командировки сохранением ширины

  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
Sub edit_work_data()
''Копирование таблицы "Командировки" с сохранением ширины и высоты ячеек на новый лист
ncol = Worksheets("Командировки").Cells(1, 1).CurrentRegion.Columns.Count
nrow = Worksheets("Командировки").Cells(1, 1).CurrentRegion.Rows.Count
Dim RowHt As Single
RowHt = Cells(1, 1).RowHeight
Worksheets("Командировки").Range(Cells(1, 1), Cells(nrow, ncol)).Copy
Worksheets.Add.Name = "Коррекция"
Worksheets("Коррекция").Cells(1, 1).PasteSpecial
Worksheets("Коррекция").Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
Cells(1, 1).RowHeight = RowHt
''Коррекция сроков командировок
Application.ScreenUpdating = False
Dim i As Integer, j As Integer
For i = 2 To 298
For j = 2 To 9
If Worksheets("Коррекция").Cells(i, 4) = Worksheets("Список целей").Cells(j, 1) And Worksheets("Коррекция").Cells(i, 3) > Worksheets("Список целей").Cells(j, 2) Then
Worksheets("Коррекция").Cells(i, 3) = Worksheets("Список целей").Cells(j, 2)
Worksheets("Коррекция").Cells(i, 3).Interior.Color = RGB(255, 204, 204)
End If
Next j
Next i
End Sub
Sub edit_work_people()
ncol = Worksheets("Коррекция").Cells(1, 1).CurrentRegion.Columns.Count
nrow = Worksheets("Коррекция").Cells(1, 1).CurrentRegion.Rows.Count
ncol1 = Worksheets("Кто едет").Cells(1, 1).CurrentRegion.Columns.Count
nrow1 = Worksheets("Кто едет").Cells(1, 1).CurrentRegion.Rows.Count
Worksheets.Add.Name = "Списокы"
Application.ScreenUpdating = False
''добавляем колонку "должность" в полный список работников
nrow2 = Worksheets("ЗАО ""Строитель""").Cells(1, 1).CurrentRegion.Rows.Count
nrow3 = Worksheets("НИИ ""Рассвет""").Cells(1, 1).CurrentRegion.Rows.Count
For i = 2 To nrow1
For j = 2 To nrow2 + nrow3
If Worksheets("Кто едет").Cells(i, 2) = Worksheets("ЗАО ""Строитель""").Cells(j, 1) Then
Worksheets("Кто едет").Cells(i, 3) = Worksheets("ЗАО ""Строитель""").Cells(j, 4)
ElseIf Worksheets("Кто едет").Cells(i, 2) = Worksheets("НИИ ""Рассвет""").Cells(j, 1) Then
Worksheets("Кто едет").Cells(i, 3) = Worksheets("НИИ ""Рассвет""").Cells(j, 4)
ElseIf Worksheets("Кто едет").Cells(i, 2) = Worksheets("Приглашенные специалисты").Cells(j, 1) Then
Worksheets("Кто едет").Cells(i, 3) = Worksheets("Приглашенные специалисты").Cells(j, 3)
End If
Next j
Next i
''заполняем таблицу командировок с составом работников
k = 1
Dim RowHt As Single
RowHt = Worksheets("Коррекция").Cells(1, 4).RowHeight
For i = 2 To nrow
For j = 2 To nrow1
If Worksheets("Коррекция").Cells(i, 1) = Worksheets("Кто едет").Cells(j, 1) Then
Worksheets("Списокы").Cells(k, 6) = Worksheets("Кто едет").Cells(j, 2)
Worksheets("Списокы").Cells(k, 1) = Worksheets("Коррекция").Cells(i, 4)
Worksheets("Списокы").Cells(k, 3) = Worksheets("Коррекция").Cells(i, 2)
Worksheets("Списокы").Cells(k, 2) = Worksheets("Коррекция").Cells(i, 1)
Worksheets("Списокы").Cells(k, 3).NumberFormat = "dd/mm/yy"
Worksheets("Списокы").Cells(k, 4) = Worksheets("Коррекция").Cells(i, 5)
Worksheets("Списокы").Cells(k, 7) = Worksheets("Кто едет").Cells(j, 3)
k = k + 1
End If
Next j
Next i
last = Worksheets("Списокы").Cells(1, 1).CurrentRegion.Rows.Count
For i = 1 To last
For j = i + 1 To last
If Worksheets("Списокы").Cells(i, 1) = Worksheets("Списокы").Cells(j, 1) Then
Worksheets("Списокы").Cells(j, 1) = ""
Worksheets("Списокы").Cells(j, 2) = ""
Worksheets("Списокы").Cells(j, 3) = ""
Worksheets("Списокы").Cells(j, 4) = ""
Else: Exit For
End If
Next j
Next i
Worksheets("Списокы").Cells(1, 1).EntireColumn.AutoFit
Worksheets("Списокы").Cells(1, 5).EntireColumn.AutoFit
Worksheets("Списокы").Cells(1, 3).EntireColumn.AutoFit
End Sub
Sub macro_заграница()
nrow1 = Worksheets("Кто едет").Cells(1, 1).CurrentRegion.Rows.Count
last1 = Worksheets("Списокы").Cells(1, 5).CurrentRegion.Rows.Count
last2 = Worksheets("Список городов вне").Cells(1, 1).CurrentRegion.Rows.Count
Application.ScreenUpdating = False
For i = 1 To last1
For j = 1 To last2
If Worksheets("Списокы").Cells(i, 4) = Worksheets("Список городов вне").Cells(j, 1) Then
Worksheets("Списокы").Cells(i, 5) = "заграницу"
End If
Next j
Next i
End Sub
Sub Find_n_Highlight()
nrow1 = Worksheets("Кто едет").Cells(1, 1).CurrentRegion.Rows.Count
last1 = Worksheets("Коррекция").Cells(2, 5).CurrentRegion.Rows.Count
last2 = Worksheets("Список городов вне").Cells(1, 1).CurrentRegion.Rows.Count
Application.ScreenUpdating = False
nrow1 = Worksheets("Кто едет").Cells(2, 3).CurrentRegion.Rows.Count
For i = 2 To nrow1
If Worksheets("Кто едет").Cells(i, 3) Like "*переводчик*" Then
Worksheets("Кто едет").Cells(i, 5) = Worksheets("Кто едет").Cells(i, 3)
End If
Next i
For i = 1 To nrow1
For j = 1 To last2
If Worksheets("Списокы").Cells(i, 4) = Worksheets("Список городов вне").Cells(j, 1) Then
Worksheets("Списокы").Cells(i, 5) = "заграницу"
For k = 2 To nrow1
If Worksheets("Кто едет").Cells(k, 1) = Worksheets("Списокы").Cells(i, 2) Then
Worksheets("Кто едет").Cells(k, 4).Interior.Color = RGB(255, 204, 204)
Rows(k).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Exit For
End If
Next k
End If
Next j
Next i
End Sub
Sub список_переводчиков()
nrow1 = 1700
k = 1
For i = 2 To nrow1
If Worksheets("Кто едет").Cells(i, 3) Like "*переводчик*" Then
Cells(k, 7) = Cells(i, 1)
Cells(k, 8) = Cells(i, 2)
Cells(k, 9) = Cells(i, 3)
k = k + 1
End If
Next i
nrow2 = Worksheets("Кто едет").Cells(1, 7).CurrentRegion.Rows.Count
For i = 1 To 1700
If Worksheets("Кто едет").Cells(i, 1) = "" Then
a = Int((nrow2 * Rnd()) + 1)
Range(Cells(a, 8), Cells(a, 9)).Copy
Cells(i, 2).PasteSpecial
End If
Next i
End Sub
Sub clear()
For i = 2 To 1700
If Cells(i, 1) Like "*переводчик*" Then
Cells(i, 1) = ""
Cells(i, 2) = ""
Cells(i, 3) = ""
End If
Next i
End Sub