consolidator

1
Attribute VB_Name = "M2_Промежуточный"
2

3
Sub П0800_Открытие_файла_ИмяФайла_Спр()
4
    ' Ищем файлы в заданной папке по заданной маске,
5
    ' и выводим на лист список их параметров.
6
    ' Просматриваются папки с заданной глубиной вложения.
7
    Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%
8
'    ПутьКПапке$ = "\\files\SDeskFilesFinance\Укрупненные планы\"
9
    ГГГГ = Format(Year(Date), "0000")
10
    MM = Format(Month(Date), "00")
11
    If MM = 12 Then ГГГГ = ГГГГ + 1
12
    ПутьКПапке$ = Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(3, 1) & "\" & ГГГГ
13
    
14
    МаскаПоиска$ = "*.xls*"
15
    ГлубинаПоиска% = Val(4)
16
    If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 999    ' без ограничения по глубине
17
    ' считываем в колекцию coll нужные имена файлов
18
    Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)
19
    '''Application.ScreenUpdating = False    ' отключаем обновление экрана
20
    ' выводим результаты (список файлов, и их характеристик) на лист
21
    макс = 0
22
    f = 0
23
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам
24
        НомерФайла = i
25
        ПутьКФайлу = coll(i)
26
        ИмяФайла = Dir(ПутьКФайлу)
27
        ДатаСоздания = FileDateTime(ПутьКФайлу)
28
        РазмерФайла = FileLen(ПутьКФайлу)
29
        ' выводим на лист очередную строку
30
'       Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
31
'        Array(НомерФайла, ИмяФайла, ПутьКФайлу, ДатаСоздания, РазмерФайла)
32
'
33
'        ' если нужна гиперссылка на файл во втором столбце
34
'       ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
35
'                                   "Открыть файл" & vbNewLine & ИмяФайла
36
'        DoEvents    ' временно передаём управление ОС
37
        q1 = InStr(1, ИмяФайла, "УП ")
38
        If IsNumeric(Val(Mid(ИмяФайла, 4, 4))) = True Then
39
            If InStr(1, ИмяФайла, "УП ") > 0 _
40
            And InStr(1, LCase(ИмяФайла), "модель") > 0 Then
41
                If макс < Val(Mid(ИмяФайла, 4, 4)) Then
42
                    If InStr(1, LCase(ПутьКФайлу), "основ") > 0 Then
43
                        макс = Val(Mid(ИмяФайла, 4, 4))
44
                        путь = Left(ПутьКФайлу, InStr(1, ПутьКФайлу, "УП ") - 1)
45
                        файл = ИмяФайла
46
                        f = 1
47
                    ElseIf f = 0 Then
48
                        путь = Left(ПутьКФайлу, InStr(1, ПутьКФайлу, "УП ") - 1)
49
                        макс = Val(Mid(ИмяФайла, 4, 4))
50
                        файл = ИмяФайла
51
                    End If
52
                End If
53
            End If
54
        End If
55
    Next
56
 q = q
57
'    путь = Left(coll(8), InStr(1, coll(8), "УП ") - 1)
58
'    Workbooks.Open путь & "УП " & макс & " Входные данные - модель*", ReadOnly:=True
59
    Workbooks.Open путь & файл, ReadOnly:=True
60
    ИмяФайла_Спр = ActiveWorkbook.Name
61
End Sub
62

63
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
64
                             Optional ByVal SearchDeep As Long = 999) As Collection
65
    ' Получает в качестве параметра путь к папке FolderPath,
66
   ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
67
   ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
68
   ' Возвращает коллекцию, содержащую полные пути найденных файлов
69
   ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
70

71
    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
72
   Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
73
   GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
74
   Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
75
End Function
76

77
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
78
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
79
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
80
   ' перебор папок осуществляется в том случае, если SearchDeep > 1
81
   ' добавляет пути найденных файлов в коллекцию FileNamesColl
82
   On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
83
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
84

85
        ' раскомментируйте эту строку для вывода пути к просматриваемой
86
       ' в текущий момент папке в строку состояния Excel
87
       ' Application.StatusBar = "Поиск в папке: " & FolderPath
88

89
        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
90
           If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
91
        Next
92
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
93
       If SearchDeep Then    ' если надо искать глубже
94
           For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
95
               GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
96
            Next
97
        End If
98
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
99
   End If
100
End Function
101

102
Sub П0260_Округление_Диаметров()
103
    Диаметр = Round(Диаметр, 0)
104
    If Диаметр = 324 Then Диаметр = 325
105
    
106
End Sub
107
Sub П0880_Автофильтр()
108
    On Error GoTo выход
109
    Столбцов = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Columns.Count
110
    Строк = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Rows.Count
111
    If ActiveSheet.AutoFilterMode Then
112
        For i = 1 To Столбцов
113
'            If Cells(1, i) = "" Then Exit For
114
            If ActiveSheet.AutoFilter.Filters(i).On Then
115
                ActiveSheet.Range(Cells(1, 1), Cells(Строк, Столбцов)).AutoFilter Field:=i
116
'                Exit For
117
            End If
118
        Next
119
    Else
120
        f = 0
121
        For i1 = 1 To 100 'Верхняя строка
122
            For i2 = 1 To 100 'левый столбец
123
                If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(i1, i2) <> "" Then f = 1: Exit For
124
            Next
125
            If f = 1 Then Exit For
126
        Next
127
        Cells(i1, i2).Select
128
        Selection.AutoFilter
129
    End If
130
выход:
131
    Range("A1").Select
132
'    Selection.AutoFilter
133
    
134
End Sub
135
Sub П0890_Вывод_всех_позиций_Перебор_файлов()
136
'    ИмяФайла_Исх = "прочие"
137
'    П0891_Вывод_всех_позиций
138
    
139
    For i = 2 To 100
140
        q = Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(i, 10)
141
        If q = "" Then Exit For
142
        If Flag_Прочие = 1 Or i > 2 Then
143
                Windows(q).Activate
144
            ИмяФайла_Исх = q
145
            П0891_Вывод_всех_позиций
146
        End If
147
    Next
148
    
149
'    ИмяФайла_Исх = "КПК.xlsx"
150
'    П0891_Вывод_всех_позиций
151
'    ИмяФайла_Исх = "прокат.xlsx"
152
'    П0891_Вывод_всех_позиций
153
'    ИмяФайла_Исх = "ТЭСЦ-2.xlsx"
154
'    П0891_Вывод_всех_позиций
155
'    ИмяФайла_Исх = "ТЭСЦ-3.xlsx"
156
'    П0891_Вывод_всех_позиций
157
'    ИмяФайла_Исх = "ТЭСЦ-5.xlsx"
158
'    П0891_Вывод_всех_позиций
159
'    ИмяФайла_Исх = "ТЭСЦ-4.xlsx"
160
'    П0891_Вывод_всех_позиций
161
'
162
End Sub
163
Sub П0891_Вывод_всех_позиций()
164
    Workbooks(ИмяФайла_Раб).Activate
165
    Sheets("Позиции на укрупнение").Activate
166
        
167
    Workbooks(ИмяФайла_Исх).Activate
168
    Листов_в_Исх = Workbooks(ИмяФайла_Исх).Sheets.Count
169
    
170
    For i_лист = 1 To Листов_в_Исх 'Перебор листов
171
        
172
        Столбцов_0 = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Columns.Count
173
        Строк_0 = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Rows.Count + 1
174
        If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Tab.Color = 255 Or InStr(1, ИмяФайла_Исх, "SAP") > 0 Then
175
            Windows(ИмяФайла_Исх).Activate
176
            Sheets(i_лист).Activate
177
            f = 0
178
            For i = 1 To 200 'Первый не пустой столбец
179
                For ii = 1 To 1000 'Первая не пустая строка
180
                    If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(ii, i) <> "" Then f = 1: Exit For
181
                Next
182
                If f = 1 Then Exit For
183
            Next
184
            If ii > 1 Then
185
                Rows("1:" & ii - 1).Select
186
                Selection.Delete Shift:=xlUp
187
                ii = 1
188
            End If
189
            If i > 1 Then
190
                For qi = 1 To i - 1
191
                    Columns("A:A").Select
192
                    Selection.Delete Shift:=xlToLeft
193
                    i = i - 1
194
                Next
195
                
196
            End If
197
            П0880_Автофильтр
198
            Столбцов_1 = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i).CurrentRegion.Columns.Count + i - 1
199
            Строк_1 = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i).CurrentRegion.Rows.Count
200
            ActiveSheet.Range(Cells(1, 1), Cells(Строк_1, Столбцов_1)).AutoFilter Field:=1, Criteria1:="<>"
201
            If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Name = "ZSRP" Then
202
            q = q
203
            End If
204
            If Строк_1 > 1 Then
205
                For i_0 = 1 To Столбцов_0
206
                    For i_1 = i To Столбцов_1
207
                        q_0 = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, i_0)
208
                        q_1 = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i_1)
209
                        If q_0 = "Наименование УП" Then i_00 = i_0
210
                        If q_0 = "Текущий продукт УП" Then i_01 = i_0
211
                            If q_0 = q_1 Then
212
                            Соотв_Столбец(i_0) = i_1
213
                            Windows(ИмяФайла_Исх).Activate
214
                            Sheets(i_лист).Activate
215
                            Range(Cells(2, i_1), Cells(Строк_1, i_1)).Select
216
                            Selection.Copy
217
                            Windows(ИмяФайла_Раб).Activate
218
                            Sheets("Позиции на укрупнение").Activate
219
                            Cells(Строк_0, i_0).Select
220
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
221
                                :=False, Transpose:=False
222
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
223
                            Cells(Строк_0, 3) = ИмяФайла_Исх
224
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
225
                            
226
    '                        Selection.Paste
227
                        End If
228
'                        If q_0 = "Вид материала в SAP ERP" And Cells(Строк_0, i_0) = "" Then
229
'                            q_2 = Строк_1 - 2
230
'                            For i_2 = Строк_0 To Строк_0 + q_2
231
'                                Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(i_2, i_0) _
232
'                                = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Name
233
'                            Next
234
'                        End If
235
                    Next
236
                Next
237
            End If
238
        End If
239
    Next
240
    If i_00 > 0 And i_01 > 0 And Строк_1 > 1 Then
241
        Windows(ИмяФайла_Раб).Activate
242
        Sheets("Позиции на укрупнение").Activate
243
        Range(Cells(2, i_00), Cells(Строк_1, i_00)).Select
244
        Selection.Copy
245
        Cells(2, i_01).Select
246
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
247
            :=False, Transpose:=False
248
        Range(Cells(2, i_00), Cells(Строк_1, i_00)).ClearContents
249
    End If
250

251
'    ActiveWindow.WindowState = xlMaximized
252
End Sub
253

254
'Sub П0890_Вывод_всех_позиций_1()
255
'    Workbooks(ИмяФайла_Раб).Activate
256
'    Sheets("Позиции на укрупнение").Activate
257
''    ActiveWindow.WindowState = xlMinimized
258
'    Столбцов_0 = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Columns.Count
259
'
260
'    Workbooks(ИмяФайла_Исх).Activate
261
'    Листов_в_Исх = Workbooks(ИмяФайла_Исх).Sheets.Count
262
'    T = Time
263
'    For i_лист = 1 To Листов_в_Исх 'Перебор листов
264
'        For i = 1 To 100
265
'            If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i) <> "" Then Exit For
266
'        Next
267
'        Столбцов_1 = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i).CurrentRegion.Columns.Count + i - 1
268
'        Строк = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i).CurrentRegion.Rows.Count
269
'        For i_строк_НП = 2 To Строк
270
'            dt = CDate(Time - T)
271
'            st = CDate(dt / i_строк_НП)
272
'            tt = CDate(st * Строк)
273
'            w = UserForm1.TextBox1.Width
274
'            k = i_строк_НП / Строк
275
'            UserForm1.TextBox2.Width = k * w
276
'            UserForm1.Label1 = "  Время: " & dt & " + " & CDate(tt - dt) & " = " & tt
277
'            UserForm1.Label2 = " Строки: " & Format(i_строк_НП, "00000") & " + " & Format(Строк - i_строк_НП, "00000") & " = " & Format(Строк, "00000")
278
'            UserForm1.Label3 = "Процент: " & Format(k, "00.0%") & " + " & Format(1 - k, "00.0%") & " = " & Format(1, "0%")
279
'            UserForm1.Repaint
280
'
281
'            Строк_0 = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, 1).CurrentRegion.Rows.Count + 1
282
'            f = 0
283
'            If i_строк_НП \ 100 <> r Then
284
'                r = i_строк_НП \ 100
285
'            End If
286
'            For i_0 = 1 To Столбцов_0
287
'                For i_1 = i To Столбцов_1
288
'                    If Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(1, i_1) _
289
'                        = Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(1, i_0) Then
290
'                            Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(Строк_0, i_0) _
291
'                                = Workbooks(ИмяФайла_Исх).Sheets(i_лист).Cells(i_строк_НП, i_1)
292
'                            If Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(Строк_0, i_0) <> "" And i_0 > 6 Then f = 1
293
'                    End If
294
'                Next
295
'            Next
296
'            If f = 0 Then
297
'                Windows(ИмяФайла_Раб).Activate
298
'                Sheets("Позиции на укрупнение").Select
299
'                Range(Cells(1, 6), Cells(1, 100)).Select
300
'                Selection.Copy
301
'                Windows(ИмяФайла_Исх).Activate
302
'                Sheets(i_лист).Select
303
'                f1 = 0
304
'                For i = 1 To 100
305
'                    If Cells(1, i) <> "" Then f1 = 1
306
'                    If Cells(1, i) = "" And f1 = 1 Then Exit For
307
'                Next
308
'                Cells(1, i).Select
309
'                ActiveSheet.Paste
310
'            End If
311
'        Next
312
'        Unload UserForm1
313
'    Next
314
'    ActiveWindow.WindowState = xlMaximized
315
'End Sub
316

317
Sub П0880_Проверка_SAP()
318
    Windows(ИмяФайла_Раб).Activate
319
    Sheets("Позиции на укрупнение").Select
320
    Строк = Cells(1, 1).CurrentRegion.Rows.Count
321
    Столбцов = Cells(1, 1).CurrentRegion.Columns.Count
322
    For i_0 = 2 To Столбцов
323
        q_0 = Cells(1, i_0)
324
        If q_0 = "Наименование УП" Then i_00 = i_0
325
        If q_0 = "Статус позиции" Then i_01 = i_0
326
        If i_00 > 0 And i_01 > 0 Then
327
            Exit For
328
        End If
329
    Next
330
    For i = 2 To Строк
331
        If Cells(i, i_00) <> Cells(i, i_01) Then
332
'             Range(Cells(i, 1), Cells(i, Столбцов)).Interior.Color = 13434879 '65535
333
             Cells(i, i_00).Font.Color = -16776961
334
             Cells(i, i_01).Font.Color = -16776961
335
'             Workbooks(ИмяФайла_Раб).Sheets("Позиции на укрупнение").Cells(i_строк_НП, 4).Font.Color = -65536
336
             
337
        End If
338
    Next
339
    
340
    
341
End Sub
342

343

344
Sub П0880_Проверка_на_укрупненные()
345
    Windows(ИмяФайла_Раб).Activate
346
    Sheets("Позиции на укрупнение").Select
347
    Строк = Cells(1, 1).CurrentRegion.Rows.Count
348
    Столбцов = Cells(1, 1).CurrentRegion.Columns.Count
349
    For i_0 = 2 To Столбцов
350
        q_0 = Cells(1, i_0)
351
        If q_0 = "Наименование УП" Then i_00 = i_0
352
        If q_0 = "Статус позиции" Then i_01 = i_0
353
        If q_0 = "Текущий продукт УП" Then i_02 = i_0
354
        If i_00 > 0 And i_01 > 0 And i_02 > 0 Then
355
            Exit For
356
        End If
357
    Next
358
    
359
    For i = 1 To 200
360
        par = Workbooks(ИмяФайла_Исх).Sheets("Привязка").Cells(1, i)
361
        par1 = Workbooks(ИмяФайла_Спр).Sheets("Справочник изделий").Cells(1, i)
362
        If par = "Код продукта SAP" Then id_sap = i
363
        If par = "Название продукта УП" Then уп_sap = i
364
        If par1 = "Наименование изделия" Then уп_план = i
365
    Next
366
    
367
    For Строк_0 = 2 To Строк
368
        If Строк_0 = 25 Then
369
        q = q
370
        End If
371
        Range("BS2").Select
372
        
373
        Cells(Строк_0, i_01).FormulaR1C1 = "=IFERROR(MATCH(RC1,'[" & ИмяФайла_Исх & "]Привязка'!C" & id_sap & ",0),""Нет"")"
374
        If Cells(Строк_0, i_01) = "Нет" Then
375
            q1 = 0
376
        Else
377
            q1 = 100
378
        End If
379
        
380
        Cells(Строк_0, i_01).FormulaR1C1 = "=IFERROR(MATCH(RC4,'[" & ИмяФайла_Исх & "]Привязка'!C" & уп_sap & ",0),""Нет"")"
381
        If Cells(Строк_0, i_01) = "Нет" Then
382
            q2 = 0
383
        Else
384
            q2 = 10
385
        End If
386
        
387
        Cells(Строк_0, i_01).FormulaR1C1 = "=IFERROR(MATCH(RC4,'[" & ИмяФайла_Спр & "]Справочник изделий'!C" & уп_план & ",0),""Нет"")"
388
        If Cells(Строк_0, i_01) = "Нет" Then
389
            q3 = 0
390
        Else
391
            q3 = 1
392
        End If
393
        Cells(Строк_0, i_01) = q1 + q2 + q3
394
        For i_q = 2 To 9
395
            q1 = Sheets("Параметры").Cells(i_q, 6) * 100
396
            q2 = Sheets("Параметры").Cells(i_q, 7) * 10
397
            q3 = Sheets("Параметры").Cells(i_q, 8)
398
            q4 = Sheets("Параметры").Cells(i_q, 9)
399
            If Cells(Строк_0, i_01) = q1 + q2 + q3 Then
400
                Cells(Строк_0, i_01) = q4
401
                Exit For
402
            End If
403
        Next
404
        
405
        If Cells(Строк_0, i_00) = "" Then
406
            Cells(Строк_0, i_01) = "Не полные параметры"
407
        End If
408
        
409
        If Cells(Строк_0, i_01) = "Не существует в SAP" _
410
        Or Cells(Строк_0, i_01) = "Не полные параметры" Then
411
            Cells(Строк_0, i_00).Font.Color = -16776961
412
            Cells(Строк_0, i_01).Font.Color = -16776961
413
            Cells(Строк_0, i_02).Font.Color = -16776961
414
        ElseIf Cells(Строк_0, i_01) = "На переукрупнение" Then
415
            Cells(Строк_0, i_00).Font.Color = -16744448
416
            Cells(Строк_0, i_01).Font.Color = -16744448
417
            Cells(Строк_0, i_02).Font.Color = -16744448
418
        ElseIf Cells(Строк_0, i_01) = "Повтор" _
419
        Or Cells(Строк_0, i_01) = "Повтор (блок)" Then
420
            Cells(Строк_0, i_00).Font.Color = -65536
421
            Cells(Строк_0, i_01).Font.Color = -65536
422
            Cells(Строк_0, i_02).Font.Color = -65536
423
        End If
424
        If Flag_SAP = 1 Then
425
            If Cells(Строк_0, i_00) = Cells(Строк_0, i_02) Then
426
                Cells(Строк_0, i_01) = "Совпадение с SAP"
427
                Cells(Строк_0, i_00).Font.ColorIndex = xlAutomatic
428
                Cells(Строк_0, i_01).Font.ColorIndex = xlAutomatic
429
                Cells(Строк_0, i_02).Font.ColorIndex = xlAutomatic
430
            ElseIf Cells(Строк_0, i_01) = "На укрупнение" _
431
            And Cells(Строк_0, i_00) <> Cells(Строк_0, i_02) Then
432
                Cells(Строк_0, i_01) = "Переукрупнение"
433
                Cells(Строк_0, i_00).Font.Color = -16744448
434
                Cells(Строк_0, i_01).Font.Color = -16744448
435
                Cells(Строк_0, i_02).Font.Color = -16744448
436
            End If
437
        End If
438
    Next
439
    ActiveWorkbook.BreakLink Name:="\\files\SDeskFilesFinance\3. Расчет УП\1. Укрупнение\1. Мэппинг\Связанные продукты SAP - УП.xlsx", Type:=xlExcelLinks
440
    Cells(1, 1).Select
441
    
442
    Sheets("Отчет").Select
443
    Range("A6").Select
444
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotCache.Refresh
445
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
446
    Sheets("Позиции на укрупнение").Select
447
    Application.CutCopyMode = False
448
End Sub
449

450
Sub П0870_Сохранение_результата()
451
    On Error Resume Next
452
'    ИмяФайла_Раб
453
    ГГГГ = Format(Year(Date), "0000")
454
    MM = Format(Month(Date), "00")
455
    DD = Format(Day(Date), "00")
456
    'Path_My & ГГГГ & " " & MM & " " & DD & "\" &
457
    Sheets("Позиции на укрупнение").Select
458
    Sheets("Позиции на укрупнение").Copy
459
    
460
    If Flag_SAP = 1 Then
461
        Path_My = Path_My & ГГГГ & " " & MM & " " & DD
462
        MkDir Path_My
463
        ActiveWorkbook.SaveAs Filename _
464
            :=Path_My & "\Проверка_SAP " & ГГГГ & " " & MM & " " & DD & ".xlsx", _
465
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
466
    Else
467
        ActiveWorkbook.SaveAs Filename _
468
            :=Path_My & ГГГГ & " " & MM & " " & DD & "\Укрупнение_" & ГГГГ & MM & DD & ".xlsx", FileFormat _
469
            :=xlOpenXMLWorkbook, CreateBackup:=False
470
    End If
471
    Flag_SAP = 0
472
    ActiveWindow.Close
473
    Workbooks(ИмяФайла_Раб).Activate
474
    Sheets("Позиции на укрупнение").Activate
475
End Sub
476
    
477

478
Sub П0900_Укрупнение()
479
    Workbooks(ИмяФайла_Раб).Activate
480
    Sheets("Позиции на укрупнение").Activate
481
    Столбцов_0 = Cells(1, 1).CurrentRegion.Columns.Count
482
    For i_0 = 1 To Столбцов_0
483
        If "Наименование УП" = Cells(1, i_0) Then Cells(i_строк_НП, i_0) = Наименование_УП
484
    Next
485
End Sub
486

487
Sub П0200_Определение_рабочей_папки()
488
    'On Error Resume Next
489
    If Application.ReferenceStyle = xlR1C1 Then
490
        Application.ReferenceStyle = xlA1
491
    End If
492
    Dim sFolder As String, sFiles As String
493
    With Application.FileDialog(msoFileDialogFolderPicker)
494
        .Title = "Выбор папки с выгрузками позиций для укрупнения"
495
        If .Show = False Then End
496
        sFolder = .SelectedItems(1)
497
    End With
498
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
499
    dlin = Len(sFolder)
500
    Path_My = sFolder
501
    Path = Left(sFolder, dlin - 1)
502
End Sub
503
Sub П0220_Очистка_листа_Позиции_на_укрупнение()
504
    Sheets("Позиции на укрупнение").Select
505
    П0880_Автофильтр
506
    Строк_0 = Cells(1, 2).CurrentRegion.Rows.Count + 1
507
    Rows("2:" & Строк_0).ClearContents
508
    Rows("2:" & Строк_0).ClearFormats
509
'    Rows("2:" & Строк_0).Select
510
'    Application.CutCopyMode = False
511
'    With Selection.Interior
512
'        .Pattern = xlNone
513
'        .TintAndShade = 0
514
'        .PatternTintAndShade = 0
515
'    End With
516
    Columns("A:A").Select
517
    Selection.NumberFormat = "#"
518
    Cells(1, 1).Select
519
End Sub
520
Sub П0230_Открытие_файла_Структура_SAP()
521
    On Error Resume Next
522
'    Workbooks.Open Path_My & "Структура SAP.xls", ReadOnly:=True
523
'    Workbooks.Open Path_My & "Структура SAP.xlsx", ReadOnly:=True
524
    Workbooks.Open Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(2, 1), ReadOnly:=True
525
    ИмяФайла_Исх = ActiveWorkbook.Name
526
'    ActiveWindow.WindowState = xlMinimized
527
End Sub
528
Sub П0235_Открытие_файла_Связанные_продукты_SAP_УП()
529
    On Error Resume Next
530
        
531
'    Workbooks.Open Path_My & "Связанные_продукты_SAP_-_УП.xls", ReadOnly:=True
532
'    Workbooks.Open Path_My & "Связанные_продукты_SAP_-_УП.xlsx", ReadOnly:=True
533
'    Workbooks.Open Path_My & "Связанные продукты SAP - УП.xls", ReadOnly:=True
534
'    Workbooks.Open Path_My & "Связанные продукты SAP - УП.xlsx", ReadOnly:=True
535
    
536
    Workbooks.Open Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(1, 1), ReadOnly:=True
537
    ИмяФайла_Исх = ActiveWorkbook.Name
538
    'ИмяФайла_Исх = Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(1, 1)
539
'    ActiveWindow.WindowState = xlMinimized
540
End Sub
541
Sub П0290_Закрытие_файла_Структура_SAP()
542
'    'On Error Resume Next
543
    Windows("Структура SAP").Activate
544
    ActiveWorkbook.Close savechanges:=False
545
    
546
    Workbooks(ИмяФайла_Раб).Activate
547
    Sheets("Позиции на укрупнение").Activate
548
    Range("C2").Select
549
    
550
End Sub
551
Sub П0295_Закрытие_файла_ИмяФайла_Спр()
552
'    'On Error Resume Next
553
    Windows(ИмяФайла_Спр).Activate
554
    ActiveWorkbook.Close savechanges:=True
555
    
556
    Workbooks(ИмяФайла_Раб).Activate
557
    Sheets("Позиции на укрупнение").Activate
558
    Range("C2").Select
559
    
560
End Sub
561
Sub П0295_Закрытие_файла_Связанные_продукты_SAP_УП()
562
    'On Error Resume Next
563
    Windows(ИмяФайла_Исх).Activate
564
'    Windows("Связанные_продукты SAP_-_УП").Activate
565
    ActiveWorkbook.Close savechanges:=True
566
    
567
    Workbooks(ИмяФайла_Раб).Activate
568
    Sheets("Позиции на укрупнение").Activate
569
    Range("C2").Select
570
    
571
End Sub
572
Sub П0230_Открытие_и_персохранение_файлов_источников()
573
    On Error Resume Next
574
    ГГГГ = Format(Year(Date), "0000")
575
    MM = Format(Month(Date), "00")
576
    DD = Format(Day(Date), "00")
577
    MkDir Path_My & ГГГГ & " " & MM & " " & DD
578
    
579
    For i = 2 To 100
580
        q = Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(i, 10)
581
        If q = "" Then Exit For
582
        If Flag_Прочие = 1 Or i > 2 Then
583
            Workbooks.Open Path_My & q
584
            ИмяФайла_Исх = ActiveWorkbook.Name
585
            ActiveWorkbook.SaveAs Filename _
586
                    :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
587
                    :=xlOpenXMLWorkbook, CreateBackup:=False
588
        End If
589
    Next
590
    
591
'    If Flag_Прочие = 1 Then
592
'        Workbooks.Open Path_My & "прочие.xlsx"
593
'        Workbooks.Open Path_My & "прочие.xlsx"
594
'        ИмяФайла_Исх = ActiveWorkbook.Name
595
'        ActiveWorkbook.SaveAs Filename _
596
'                :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
597
'                :=xlOpenXMLWorkbook, CreateBackup:=False
598
'    End If
599
'
600
'    Workbooks.Open Path_My & "КПК.xls"
601
'    Workbooks.Open Path_My & "КПК.xlsx"
602
'    ИмяФайла_Исх = ActiveWorkbook.Name
603
'    ActiveWorkbook.SaveAs Filename _
604
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
605
'            :=xlOpenXMLWorkbook, CreateBackup:=False
606
'
607
'    Workbooks.Open Path_My & "прокат.xls"
608
'    Workbooks.Open Path_My & "прокат.xlsx"
609
'    ИмяФайла_Исх = ActiveWorkbook.Name
610
'    ActiveWorkbook.SaveAs Filename _
611
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
612
'            :=xlOpenXMLWorkbook, CreateBackup:=False
613
'
614
'    Workbooks.Open Path_My & "ТЭСЦ-2.xls"
615
'    Workbooks.Open Path_My & "ТЭСЦ-2.xlsx"
616
'    ИмяФайла_Исх = ActiveWorkbook.Name
617
'    ActiveWorkbook.SaveAs Filename _
618
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
619
'            :=xlOpenXMLWorkbook, CreateBackup:=False
620
'
621
'    Workbooks.Open Path_My & "ТЭСЦ-3.xls"
622
'    Workbooks.Open Path_My & "ТЭСЦ-3.xlsx"
623
'    ИмяФайла_Исх = ActiveWorkbook.Name
624
'    ActiveWorkbook.SaveAs Filename _
625
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
626
'            :=xlOpenXMLWorkbook, CreateBackup:=False
627
'
628
'    Workbooks.Open Path_My & "ТЭСЦ-5.xls"
629
'    Workbooks.Open Path_My & "ТЭСЦ-5.xlsx"
630
'    ИмяФайла_Исх = ActiveWorkbook.Name
631
'    ActiveWorkbook.SaveAs Filename _
632
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
633
'            :=xlOpenXMLWorkbook, CreateBackup:=False
634
'
635
'    Workbooks.Open Path_My & "ТЭСЦ-4.xls"
636
'    Workbooks.Open Path_My & "ТЭСЦ-4.xlsx"
637
'    ИмяФайла_Исх = ActiveWorkbook.Name
638
'    ActiveWorkbook.SaveAs Filename _
639
'            :=Path_My & ГГГГ & " " & MM & " " & DD & "\" & ИмяФайла_Исх, FileFormat _
640
'            :=xlOpenXMLWorkbook, CreateBackup:=False
641
    
642
End Sub
643
Sub П0290_Закрытие_файлов_источников()
644
'    'On Error Resume Next
645
    For i = 2 To 100
646
        q = Workbooks(ИмяФайла_Раб).Sheets("Параметры").Cells(i, 10)
647
        If q = "" Then Exit For
648
        If Flag_Прочие = 1 Or i > 2 Then
649
            Windows(q).Activate
650
'            ActiveWorkbook.Close savechanges:=False
651
            ActiveWorkbook.Close savechanges:=True
652
        End If
653
    Next
654
'    If Flag_Прочие = 1 Then
655
'        Windows("прочие.xlsx").Activate
656
''        ActiveWorkbook.Close savechanges:=False
657
'        ActiveWorkbook.Close savechanges:=True
658
'    End If
659
'
660
'    Windows("КПК.xlsx").Activate
661
''    ActiveWorkbook.Close savechanges:=False
662
'    ActiveWorkbook.Close savechanges:=True
663
'
664
'    Windows("прокат.xlsx").Activate
665
''    ActiveWorkbook.Close savechanges:=False
666
'    ActiveWorkbook.Close savechanges:=True
667
'
668
'    Windows("ТЭСЦ-2.xlsx").Activate
669
''    ActiveWorkbook.Close savechanges:=False
670
'    ActiveWorkbook.Close savechanges:=True
671
'
672
'    Windows("ТЭСЦ-3.xlsx").Activate
673
''    ActiveWorkbook.Close savechanges:=False
674
'    ActiveWorkbook.Close savechanges:=True
675
'
676
'    Windows("ТЭСЦ-5.xlsx").Activate
677
''    ActiveWorkbook.Close savechanges:=False
678
'    ActiveWorkbook.Close savechanges:=True
679
'
680
'    Windows("ТЭСЦ-4.xlsx").Activate
681
''    ActiveWorkbook.Close savechanges:=False
682
'    ActiveWorkbook.Close savechanges:=True
683
    
684
    Workbooks(ИмяФайла_Раб).Activate
685
    Sheets("Позиции на укрупнение").Activate
686
    Range("C2").Select
687
    
688
End Sub
689

690

691

692