Option Explicit
Sub macros_name()
Dim c As Integer
Dim i, j, o As Long
Dim some_code, small_file, file_total_data, created_file As String
Dim FSO, work_folder, work_file, dict_target, dict_another As Object
Dim l_inc_data, l_out As Workbook
'Как я узнал тут (https://qna.habr.com/q/1071426), _
часть переменных объявлена как Variant из-за перечисления через запятую.
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set work_folder = FSO.GetFolder(ThisWorkbook.Path)
On Error Resume Next
If l_input.AutoFilterMode Then l_input.ShowAllData
If l_main.AutoFilterMode Then l_main.ShowAllData
If l_data.AutoFilterMode Then l_data.ShowAllData
On Error GoTo 0
'Здесь забираются данные из файла. 10 колонок и около 2000 строк. Здесь всегда всё хорошо.
If Len(l_input.Cells(2, 1).Value) > 0 Then
j = l_main.Cells(l_main.Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To l_input.Cells(l_input.Rows.Count, 1).End(xlUp).Row
l_main.Cells(j, 8).NumberFormat = "@"
l_main.Cells(j, 11).NumberFormat = "@"
For c = 1 To 10
l_main.Cells(j, c).Value = l_input.Cells(i, c).Value
Next c
some_code = add_data(args) 'тут функцию менял на ГСЧ - без толку.
l_main.Cells(j, 11).Value = some_code
If Len(l_main.Cells(j, 11).Value) > 0 _
And dict_target(l_main.Cells(j, 11).Value) <> "no data" Then
l_main.Cells(j, 12).Value = dict_another.Item(l_main.Cells(j, 11).Value)
small_file = ThisWorkbook.Path & "\part_of_name" & some_code & " " & Date & ".xlsx"
file_total_data = ThisWorkbook.Path & "\part_of_name" & l_main.Cells(j, 12).Value & " " _
& Date & ".xlsx"
'crate_new_file создаёт новый файл xlsx, делает заголовки колонок и закрывает файл.
If Not FSO.FileExists(small_file) Then Call crate_new_file(small_file, False, row_log)
If Not FSO.FileExists(file_total_data) Then Call crate_new_file(file_total_data, True, row_log)
Set l_out = Application.Workbooks.Open(Filename:=small_file)
o = l_out.Sheets(1).Cells(l_out.Sheets(1).Rows.Count, 1).End(xlUp).Row + 1
For c = 1 To 10
l_out.Sheets(1).Cells(o, c).Value = l_input.Cells(i, c).Value
Next c
l_out.Close True
Set l_out = Application.Workbooks.Open(Filename:=file_total_data)
o = l_out.Sheets(1).Cells(l_out.Sheets(1).Rows.Count, 1).End(xlUp).Row + 1
For c = 1 To 10
l_out.Sheets(1).Cells(o, c).Value = l_input.Cells(i, c).Value
Next c
l_out.Close True
End If
j = j + 1
Next i
End If
'Здесь макрос делает остальные задачи. Тут тоже всегда всё хорошо.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub....
Dim cells_to_copy As Range
....
If Len(l_input.Cells(2, 1).Value) > 0 Then
j = l_main.Cells(l_main.Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To l_input.Cells(l_input.Rows.Count, 1).End(xlUp).Row
l_main.Cells(j, 8).NumberFormat = "@"
l_main.Cells(j, 11).NumberFormat = "@"
Set cells_to_copy = l_input.Range(l_input.Cells(i, 1), l_input.Cells(i, 10))
l_main.Range(l_main.Cells(j, 1), l_main.Cells(j, 10)).Value = cells_to_copy.Value
some_code = add_data(args) 'тут функцию менял на ГСЧ - без толку.
l_main.Cells(j, 11).Value = some_code
If Len(l_main.Cells(j, 11).Value) > 0 _
And dict_target(l_main.Cells(j, 11).Value) <> "no data" Then
l_main.Cells(j, 12).Value = dict_another.Item(l_main.Cells(j, 11).Value)
small_file = ThisWorkbook.Path & "\part_of_name" & some_code & " " & Date & ".xlsx"
file_total_data = ThisWorkbook.Path & "\part_of_name" & l_main.Cells(j, 12).Value & " " _
& Date & ".xlsx"
If Not FSO.FileExists(small_file) Then Call crate_new_file(small_file, False, row_log)
If Not FSO.FileExists(file_total_data) Then Call crate_new_file(file_total_data, True, row_log)
Set l_out = Application.Workbooks.Open(Filename:=small_file)
o = l_out.Sheets(1).Cells(l_out.Sheets(1).Rows.Count, 1).End(xlUp).Row + 1
output_data.Sheets(1).Range( _
output_data.Sheets(1).Cells(current_row, 1), output_data.Sheets(1).Cells(current_row, output_data.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column) _
).NumberFormat = "@"
output_data.Sheets(1).Range( _
output_data.Sheets(1).Cells(current_row, 1), output_data.Sheets(1).Cells(current_row, output_data.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column) _
).Value = copied_data.Value
l_out.Close True
Set l_out = Nothing
Set l_out = Application.Workbooks.Open(Filename:=file_total_data)
o = l_out.Sheets(1).Cells(l_out.Sheets(1).Rows.Count, 1).End(xlUp).Row + 1
output_data.Sheets(1).Range( _
output_data.Sheets(1).Cells(current_row, 1), output_data.Sheets(1).Cells(current_row, output_data.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column) _
).NumberFormat = "@"
output_data.Sheets(1).Range( _
output_data.Sheets(1).Cells(current_row, 1), output_data.Sheets(1).Cells(current_row, output_data.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column) _
).Value = copied_data.Value
l_out.Sheets(1).Cells(o, 11).Value = some_code
l_out.Close True
Set l_out = Nothing
End If
Set cells_to_copy = Nothing
j = j + 1
Next i
End If
Средний
Простой
