Добрый день
Написал макрос, но в процессе работы появляется сообщение что недостаточно памяти
что можно оптимизировать?
Написал макрос, но в процессе работы появляется сообщение что недостаточно памяти
что можно оптимизировать?
Код |
---|
Sub obrabotka() FileOpen = Application.GetOpenFilename If FileOpen <> False Then Workbooks.Open (FileOpen) Else: Exit Sub End If Application.ScreenUpdating = False For i = 2 To Worksheets(1).Cells(Rows.Count, 4).End(xlUp).Row imya = Worksheets(1).Cells(i, 4) If Not SheetExist(imya) Then Sheets.Add after:=Sheets(1) ActiveSheet.Name = imya Worksheets(imya).Rows(1).Value = Worksheets(1).Rows(1).Value Worksheets(imya).Rows(Sheets(imya).Cells(Rows.Count, 4).End(xlUp).Row + 1).Value = Worksheets(1).Rows(i).Value Else Worksheets(imya).Rows(Sheets(imya).Cells(Rows.Count, 4).End(xlUp).Row + 1).Value = Worksheets(1).Rows(i).Value End If Next i For i = 2 To Sheets.Count Worksheets(i).Copy MsgBox Sheets(1).Name ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(Sheets(1).Name, """", "_") & ".xlsx" ActiveWorkbook.Close Next i Application.ScreenUpdating = True End Sub Public Function SheetExist(ShName) Dim sh As Worksheet On Error Resume Next Set sh = Worksheets(ShName) SheetExist = Not (Err.Number <> 0) On Error GoTo 0 End Function |