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
248
249
250
251
252
253
254
255
256
257
| Sub АЖ()
'Формируем Заключки
Const ИмяФайлаШаблона = "ДОП_СОГЛ.docx"
Const КоличествоОбрабатываемыхСтолбцов = 90
Const РасширениеСоздаваемыхФайлов = ".docx"
ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Шаблоны" & ИмяФайлаШаблона)
НоваяПапка = NewFolderName & Application.PathSeparator
Dim row As Range
Dim rownumber, index As Integer
Dim DocumentNumber As Integer
Dim GosbValue, NumberOfRow As String
Dim i%
Dim EndOfBlock As Integer
Dim ILastRow As Long
Dim A(1 To 8) As Integer
Dim GOSB(1 To 7) As String
Dim length As Integer
Dim BlockLength(1 To 7) As Integer
Dim Start(1 To 7) As Integer
If FindList("Итог для слияния") = False Then
msg = "Листа Итог для слияния не существует"
MsgBox msg, vbExclamation, "Добавьте данные"
Exit Sub
Else: Sheets("Итог для слияния").UsedRange.Value = Sheets("Итог для слияния").UsedRange.Value
End If
For j = 1 To 400
For i = 1 To 1000
If CStr(Cells(i, j).Value) = "#ССЫЛКА!" Then
msg = "В одной или нескольких ячейках содержится ошибка типа #ССЫЛКА! исправьте основной лист с данными и разбейте на листы с помощью PLEX заново."
MsgBox msg, vbExclamation, "Ошибка в шаблоне"
Exit Sub
End If
Next i
Next j
Sheets("Итог для слияния").Select
ILastRow = Cells(Rows.Count, "C").End(xlUp).row ': rc = r - 2
If ILastRow = 1 Then
msg = "На листе Итог для слияния нет данных!"
MsgBox msg, vbExclamation, "Добавьте данные"
Exit Sub
End If
msg = "Запущено формирование файлов. Пожалуйста, подождите"
MsgBox msg, vbInformation, "Внимание"
Application.Cursor = xlWait 'xlNorthwestArrow 'xlIBeam
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Доп. соглашения создаются, подождите..."
rownumber = 2
EndOfBlock = 0
'ILastRow = ActiveSheet.UsedRange.Rows.Count
index = 0
'шапка и сортировка
' Sheets("Итог для слияния").Rows("1:1").Delete
' Sheets("Шапка").Rows("1:1").Copy
Sheets("Итог для слияния").Select
'ActiveWindow.SmallScroll Down:=-21
Cells.Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Итог для слияния").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Итог для слияния").Sort.SortFields.Add Key:=Range( _
"C2:C501"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Итог для слияния").Sort.SortFields.Add Key:=Range( _
"O2:O501"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Итог для слияния").Sort
.SetRange Range("A1:CQ501")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'добавили шапку на лист, сделали сортировку
For rownumber = 2 To ILastRow
Do Until EndOfBlock <> 0
If Cells(rownumber, 3).Value = Cells(rownumber + 1, 3).Value And _
(Cells(rownumber, 3).Value = "8610" Or _
Cells(rownumber, 3).Value = "8611" Or _
Cells(rownumber, 3).Value = "8612" Or _
Cells(rownumber, 3).Value = "8613" Or _
Cells(rownumber, 3).Value = "8614" Or _
Cells(rownumber, 3).Value = "8589" Or _
Cells(rownumber, 3).Value = "9042") Then
rownumber = rownumber + 1
Else:
index = index + 1
EndOfBlock = rownumber
A(index) = EndOfBlock
GOSB(index) = Cells(rownumber, 6).Value
If index = 1 Then
Start(index) = 2
BlockLength(index) = A(index) - Start(index) + 1
Else:
Start(index) = A(index - 1) + 1
BlockLength(index) = A(index) - Start(index) + 1
End If
End If
Loop
If index <= 6 Then EndOfBlock = 0
Next rownumber
''''''Здесь и далее создание файлов word
Sheets("Итог для слияния").Select
r = Cells(Rows.Count, "C").End(xlUp).row: rc = r - 1
If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
If rc > 500 Then MsgBox "Строк для обработки больше 500, удалите лишние строки", vbCritical: Exit Sub
For index = 1 To 7 Step 1
Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")
ИмяФайла = GOSB(index) & " ДОП.СОГЛ " & BlockLength(index)
Filename = НоваяПапка & ИмяФайла & РасширениеСоздаваемыхФайлов
DocumentNumber = 0
Set WD = WA.documents.Add(ПутьШаблона): DoEvents
With WA
.Selection.WholeStory
.Selection.Copy
End With
startrow = "" & Val(Start(index)) & ":"
If startrow = "0:" Then GoTo Point: 'цикл выполняться дальше не должен
Application.StatusBar = "Создаются доп. соглашения для " & GOSB(index) & ", подождите..."
For Each row In ActiveSheet.Rows(startrow & CStr(A(index)))
With row
DocumentNumber = DocumentNumber + 1
For i = 1 To КоличествоОбрабатываемыхСтолбцов
FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
Application.StatusBar = "Замена данных для " & GOSB(index) & " в шаблоне, подождите...сейчас заменяются данные " & Cells(i, 15)
With WD.Range.Find
.Text = FindText
.Replacement.Text = ReplaceText
.Forward = True
.Wrap = 1
.Format = False: .MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
DoEvents
Next i
If DocumentNumber < BlockLength(index) Then
With WA
.Selection.EndOf
.Selection.InsertBreak
.Selection.StartOf
.Selection.PasteAndFormat (wdFormatOriginalFormatting)
End With
End If
WD.SaveAs Filename:
End With
Next row
Application.StatusBar = "Сохранение файла Word для " & GOSB(index) & " подождите..."
Point:
'разбивка по ГОСБам
WD.Close False: DoEvents
WA.Quit False:
Next index
Application.Cursor = xlDefault
End If
Next i
End With
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
msg = "Доп. соглашения сформированы! Документы находятся в папке " & vbNewLine & НоваяПапка
MsgBox msg, vbInformation, "Готово"
End Sub
Sub ВыделяемЯчейкиСОшибками_2()
On Error Resume Next
Set ErrRa = ActiveSheet.UsedRange.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If Not ErrRa Is Nothing Then
ErrRa.Select ' выделяем все ячейки с ошибками
MsgBox "Найдено ошибок в формулах: " & ErrRa.Cells.Count
End If
End Sub
Public Sub ВернутьКурсор()
Application.Cursor = xlDefault
End Sub
Public Function FindList(SheetName As String) As Boolean
FindList = False
For i = 1 To Sheets.Count ' Перечисляем листы книги
If Sheets(i).Name = SheetName Then 'Сравниваем имя текущего листа с SheetName
FindList = True
Exit Function
End If
Next i
End Function
Sub DeleteFolder()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
fso.DeleteFolder (CStr(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Доп. соглашения, сформированные " & Get_Date)))
End Sub
Function NewFolderName() As String
NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Доп. соглашения, сформированные " & Get_Now)
MkDir NewFolderName
End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function |
(
