Код рабочий, но случайным образом Эксель глючит при сохранении. Где ошибка7

[grenles]

Вот код процедуры - рабочий.

Задача - есть файл определенной структуры - в одном столбце - название.
В соседнем подряд без пустых ячеек - содержимое этого названия.
Пример

ЧП Матроскин
кафе Буренка
ферма Дядя Шарик
магазин Умелые руки

Задача из одного большого списка в экселе сделать 1 000 маленьких файлов по названию стуктуры типа "ЧП Матроскин"

ошибка в том, что произвольно Эксель неожиданно при сохранении файла дает ему имя EFTR56000019.xls вместо желательного "ЧП Матроскин".
Файлов много и каждый раз руками ловить и переименовывать тяжко.

Где я ошибся. Я не большой знаток макросов. ПОловина кода - переделки записей макрокоманд. Ну и кое-где книги.

Почему так получается при сохранении? Утечка памяти? или Эксель не успевает сохранить, а уже идет команда закрытия????

Код приведен полностью, кроме данным на ЛИСТ1. Там размещены только начальные адреса ячеек откуда плясать и пути и названия книг для открытия.

Спасибо за помощь.

[grenles]

	
	
Private Sub CommandButton3_Click()
 ' создаем указание
 MEGA_str = "0123456789qwertyuiopasdfghjklzxcvbnmйцукенгшщзхъёфывапролджэячсмитьбюQWERTYUIOPASDFGHJKLZXCVBNMЙЦУКЕЁНГШЩЗФЫВАПРОЛДЖЭЯЧСМИТЬБЮ"
 
 A_Start = 14
 Stolb = 5
 
 WorkBookMy = Application.ThisWorkbook.Name
 SHB_path = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 0, Stolb)
 SHB_file = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 1, Stolb)
 SHB_sheet = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 2, Stolb)
 
 ISU_path = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 5, Stolb)
 ISU_file = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 6, Stolb)
 ISU_sheet = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 7, Stolb)
 
 ' проверка чего считали
 'Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 3, Stolb + 1) = file_ISU
 
' адрес ячейки для ИЗЮ начала Юриков
ISU_ur_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 7, Stolb + 2)
ISU_ur_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 7, Stolb + 1)

ISU_tu_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 6, Stolb + 2)
ISU_tu_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 6, Stolb + 1)

' адрес ячейки для ШАБЛОНА начала Юриков
SHB_ur_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 10, Stolb + 2)
SHB_ur_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 10, Stolb + 1)

SHB_tu_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 9, Stolb + 2)
SHB_tu_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 9, Stolb + 1)

' начало отчетов
WBK_ot_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 4, Stolb + 2)
WBK_ot_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 4, Stolb + 1)

WBK_dt_stol = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 2, Stolb + 2)
WBK_dt_stro = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start - 2, Stolb + 1)


sum_file = 0
sum_tu = 0
sum_ur = 0
step = 0
str_sero = 0

Application.Workbooks.Open (ISU_path + "\" + ISU_file)
' НАЧАЛО ЦИКЛА ЮРИКИ
'открываем назад шаблон
Do
Application.Workbooks.Open (SHB_path + "\" + SHB_file)
' ИЩУ НАЗВАНИЕ ТЕКУЩЕГО ЮРИКА

Isu_Name = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_ur_stro, ISU_ur_stol)
sum_ur = sum_file + 1

' убираю запреденные символы - оставляю только буквы и слова
' Len_Strok = Len(ISU_name)

ISU_new_name = ""
LenStr = Len(Isu_Name)
For i = 1 To LenStr
 symbol = Mid(Isu_Name, i, 1)
 If InStr(1, MEGA_str, symbol) > 0 Then
  ISU_new_name = ISU_new_name + symbol
 End If
Next i

' сохраняю под найденным именем
Application.Workbooks(SHB_file).Activate
   
' НАЧАЛО ЦИКЛА ТУ
' пока в ТУ не пробела - делаю из них строку.
All_str = ""
ISU_tu_temp = 0
 ISU_tu_stro = ISU_tu_stro - 1
Do
 ISU_tu_stro = ISU_tu_stro + 1
 ISU_tu_temp = ISU_tu_temp + 1
 sum_tu = sum_tu + 1
 stemp = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_tu_stro, ISU_tu_stol)
 If stemp <> "" Then
  All_str = All_str + Str(ISU_tu_temp) + "). " + stemp + ", "
 End If
  
Loop Until stemp = ""

lp = Len(All_str)
' пишем строку в файл - шаблон ТУ
Application.Workbooks(SHB_file).Sheets(SHB_sheet).Cells(SHB_ur_stro, SHB_ur_stol) = All_str
Application.Workbooks(SHB_file).Sheets(SHB_sheet).Cells(SHB_tu_stro, SHB_tu_stol) = Isu_Name
Application.Workbooks(SHB_file).SaveAs Filename:=ISU_path + "\" + ISU_new_name, _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Save // ГДЕ-ТО ЗДЕСЬ РУБИТСЯ НА СОХРАНЕНИИ
ActiveWindow.Close
sum_file = sum_file + 1

' пишем отчеты
' суммарный
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_ot_stro, WBK_ot_stol) = sum_file
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_ot_stro + 1, WBK_ot_stol) = sum_ur
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_ot_stro + 2, WBK_ot_stol) = sum_tu

' подробный
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_dt_stro + step, WBK_dt_stol) = Isu_Name
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_dt_stro + step, WBK_dt_stol + 1) = sum_tu
Application.Workbooks(WorkBookMy).Sheets(1).Cells(WBK_dt_stro + step, WBK_dt_stol + 2) = All_str
step = step + 1

' ищем следующую не пустую строку
ISU_tu_stro = ISU_tu_stro - 1
Do
 ISU_tu_stro = ISU_tu_stro + 1
 stemp = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_tu_stro, ISU_tu_stol)
  
  If stemp = "" Then
   str_sero = str_sero + 1
  End If
Loop Until (str_sero > 30) Or (stemp <> "")

' обнуляем число подряд идущих нулевых строк
If (stemp <> "") And (str_zero < 30) Then
 str_sero = 0
 ISU_ur_stro = ISU_tu_stro - 3
End If

Loop Until str_zero > 30
End Sub

[EducatedFool]

Много буков...

На будущее: вместо

    WorkBookMy = Application.ThisWorkbook.Name
    SHB_path = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 0, Stolb)
    SHB_file = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 1, Stolb)
    SHB_sheet = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 2, Stolb)

    ISU_path = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 5, Stolb)
    ISU_file = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 6, Stolb)
    ISU_sheet = Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 7, Stolb)

лучше использовать что-то вроде этого:

    With ThisWorkbook.Worksheets(1)
        SHB_path = .Cells(A_Start + 0, Stolb)
        SHB_file = .Cells(A_Start + 1, Stolb)
        SHB_sheet = .Cells(A_Start + 2, Stolb)
        ISU_path = .Cells(A_Start + 5, Stolb)
        ISU_file = .Cells(A_Start + 6, Stolb)
        ISU_sheet = .Cells(A_Start + 7, Stolb)
    End With

Практически во всём коде слово Application. - лишнее (и без него всё работает)

По теме:
Рекомендую перед проблемной строкой кода поставить

Debug.Print ISU_path + "\" + ISU_new_name

Вдруг проблема в определённой строчке на листе - тогда Вы хотя бы узнаете, в какой именно.

Почему так получается при сохранении? Утечка памяти? или Эксель не успевает сохранить, а уже идет команда закрытия????

Нет, сохранить он успевает. Команды выполняются всегда в нужном порядке - новая команда не исполняется, пока не завершена предыдущая.

Возможна нехватка ресурсов - при работе с сотнями книг макросы порой зависают.
Я в таких случаях (редко, но бывает - к примеру, когда программно создаёшь тысячи листов или книг) просто оптимизирую макрос путем переписывания его "с нуля" (ищу способ не создавать так много объектов)

Хотите получить более подробный ответ - прикрепите к сообщению проблемный файл.

[grenles]

ага, спасибо, понял. Где-то я так и думал про ресурсы.

Файл дать не могу, так как это хоть и не большая секретность, но слегка не распространяемая информация.

А единственный выход вижу выгружать партиями, допустим по 50 наименований... щас буду проводить экспенимент и учту ваши пожелания.
Код выложу.

[Teslenko_EA]

Здравствуйте grenles.
"про ресурсы" действительно стоит подумать, и один из самых эффективных способов это директива:
Option Explicit
Она заставит Вас объявлять переменные перед использованием, а систему выделять переменным только определенное кол-во памяти.
Сейчас в коде не декларируется ни одна переменная, а применяется достаточно много. Тип Variant не самым лучшим образом обращается с памятью, тип переменных лучше указывать явно. В свете сказанного EducatedFool выше, рекомендую в код внести подобные изменения:

Option Explicit
Private Sub CommandButton1_Click()
Const MEGA_str = "0123456789qwertyuiopasdfgh........
Dim A_Start  As Long, Stolb As Integer
Dim WorkBookMy As String, SHB_path As String, SHB_file As String
.... 
With Workbooks(WorkBookMy).Sheets(1)
    WorkBookMy = ThisWorkbook.Name
    SHB_path = .Cells(A_Start + 0, Stolb)
    SHB_file = Cells(A_Start + 1, Stolb)
   ...

Евгений.

[grenles]

спасибо, понял

[grenles]

кстати. я тут просто случайно попался на такой вещи - на диске С кончилось место и у меня закрались смутные подозрения что мой глюк связан с временными файлами экселя, которые просто некуда писать.
А все из-за каспера, он мне логов напилил на 9 гигов, я просто офигел!!!!

[grenles]

100% у Экселя кончается память!!! Пишет "out of memory"

Помогите понять, где она "утекает" и что изменить в коде?

[grenles]

Прикольно... вынес объявления переменных за процедуру
Private Sub CommandButton1_Click() - Эксель стал есть память меньше. но все равно она стала расти не в геометрической прогрессии, а в арифметической.
Ищу решение дальше.

[grenles]

Option Explicit
Const MEGA_str = "0123456789qwertyuiopasdfghjklzxcvbnmйцукенгшщзхъёфывапролджэячсмитьбюQWERTYUIOPASDFGHJKLZXCVBNMЙЦУКЕЁНГШЩЗФЫВАПРОЛДЖЭЯЧСМИТЬБЮ"
Dim WorkBookMy, SHB_path, SHB_file, SHB_sheet, ISU_path, ISU_file, ISU_sheet As String
Dim ISU_new_name, ISU_name, All_str As String
Dim ISU_ur_stol, ISU_ur_stro, ISU_tu_stol, ISU_tu_stro, SHB_ur_stol, SHB_ur_stro, SHB_tu_stol, SHB_tu_stro As Integer
Dim A_Start, Stolb, LenStr, i As Integer
Dim sum_file, sum_tu, sum_ur, step, str_zero, WBK_ot_stol, WBK_ot_stro, WBK_dt_stol, WBK_dt_stro As Integer
Dim symbol, NameB, L1  As String
Dim dlgAnswer As Boolean

Private Sub CommandButton3_Click()
 ' создаем указание

 A_Start = 18
 Stolb = 5
 
 WorkBookMy = Application.ThisWorkbook.Name
 With Workbooks(WorkBookMy).Sheets(1)

 SHB_path = .Cells(A_Start + 0, Stolb)
 SHB_file = .Cells(A_Start + 1, Stolb)
 SHB_sheet = .Cells(A_Start + 2, Stolb)
 
 ISU_path = .Cells(A_Start + 5, Stolb)
 ISU_file = .Cells(A_Start + 6, Stolb)
 ISU_sheet = .Cells(A_Start + 7, Stolb)
 
 ' проверка чего считали
 'Application.Workbooks(WorkBookMy).Sheets(1).Cells(A_Start + 3, Stolb + 1) = file_ISU
 ' адрес ячейки для ИЗЮ начала Юриков
ISU_ur_stol = .Cells(A_Start - 11, Stolb + 2)
ISU_ur_stro = .Cells(A_Start - 11, Stolb + 1)

ISU_tu_stol = .Cells(A_Start - 10, Stolb + 2)
ISU_tu_stro = .Cells(A_Start - 10, Stolb + 1)

' адрес ячейки для ШАБЛОНА начала Юриков
SHB_ur_stol = .Cells(A_Start - 14, Stolb + 2)
SHB_ur_stro = .Cells(A_Start - 14, Stolb + 1)

SHB_tu_stol = .Cells(A_Start - 13, Stolb + 2)
SHB_tu_stro = .Cells(A_Start - 13, Stolb + 1)

' начало отчетов
WBK_ot_stol = .Cells(A_Start - 8, Stolb + 2)
WBK_ot_stro = .Cells(A_Start - 8, Stolb + 1)

WBK_dt_stol = .Cells(A_Start - 6, Stolb + 2)
WBK_dt_stro = .Cells(A_Start - 6, Stolb + 1)
End With

sum_file = 0
sum_tu = 0
sum_ur = 0
step = 0
str_zero = 0

' НАЧАЛО ЦИКЛА ЮРИКИ
'открываем назад шаблон
Application.EnableEvents = False
Application.Workbooks.Open (ISU_path + "\" + ISU_file)
Do
Application.Workbooks.Open (SHB_path + "\" + SHB_file)
' ИЩУ НАЗВАНИЕ ТЕКУЩЕГО ЮРИКА

ISU_name = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_ur_stro, ISU_ur_stol)
sum_ur = sum_file + 1

' убираю запреденные символы - оставляю только буквы и слова
' Len_Strok = Len(ISU_name)

ISU_new_name = ""
' создаем уникальное имя за счет прибавления текущего времени.
NameB = ISU_name + Str(Hour(Now)) + Str(Minute(Now)) + Str(Timer)
LenStr = Len(NameB)
i = 1
While (i <= LenStr) And (Len(ISU_new_name) < 200)
 symbol = Mid(NameB, i, 1)
 If InStr(1, MEGA_str, symbol) > 0 Then
  ISU_new_name = ISU_new_name + symbol
 End If
 i = i + 1
Wend

' сохраняю под найденным именем
'Application.Workbooks(SHB_file).Activate
   
' НАЧАЛО ЦИКЛА ТУ
' пока в ТУ не пробела - делаю из них строку.
All_str = ""
i = 0
 ISU_tu_stro = ISU_tu_stro - 1
Do
 ISU_tu_stro = ISU_tu_stro + 1
 i = i + 1
 sum_tu = sum_tu + 1
 symbol = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_tu_stro, ISU_tu_stol)
 If symbol <> "" Then
  All_str = All_str + Str(i) + "). " + symbol + ", "
 End If
  
Loop Until symbol = ""

'lp = Len(All_str)
' пишем строку в файл - шаблон ТУ
With Application.Workbooks(SHB_file).Sheets(SHB_sheet)
.Cells(SHB_ur_stro, SHB_ur_stol) = All_str
.Cells(SHB_tu_stro, SHB_tu_stol) = ISU_name
End With

symbol = ISU_path + "\" + ISU_new_name
Application.Workbooks(SHB_file).SaveAs Filename:=symbol, _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

'ActiveWorkbook.Save
ActiveWorkbook.Close
'ActiveWindow.Close


sum_file = sum_file + 1

' ищем следующую не пустую строку
ISU_tu_stro = ISU_tu_stro - 1
Do
 ISU_tu_stro = ISU_tu_stro + 1
 symbol = Application.Workbooks(ISU_file).Sheets(ISU_sheet).Cells(ISU_tu_stro, ISU_tu_stol)
  
  If symbol = "" Then
   str_zero = str_zero + 1
  End If
Loop Until (str_zero > 30) Or (symbol <> "")

' пишем отчеты
' суммарный
With Application.Workbooks(WorkBookMy).Sheets(1)
.Cells(WBK_ot_stro, WBK_ot_stol) = sum_file
.Cells(WBK_ot_stro + 1, WBK_ot_stol) = sum_ur
.Cells(WBK_ot_stro + 2, WBK_ot_stol) = sum_tu

' подробный
.Cells(WBK_dt_stro + step, WBK_dt_stol) = ISU_name
.Cells(WBK_dt_stro + step, WBK_dt_stol + 1) = sum_tu
.Cells(WBK_dt_stro + step, WBK_dt_stol + 2) = str_zero
.Cells(WBK_dt_stro + step, WBK_dt_stol + 2) = ISU_name
.Cells(WBK_dt_stro + step, WBK_dt_stol + 3) = All_str
End With

step = step + 1

' обнуляем число подряд идущих нулевых строк
If (ISU_name <> "") And (str_zero < 30) Then
 str_zero = 0
 ISU_ur_stro = ISU_tu_stro - 3
End If

Loop Until str_zero > 30
Application.EnableEvents = True
MsgBox ("Конец работы")
End Sub