Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

Как "Облегчить" файл (VBA)

Автор Rita, 24.03.2014, 10:02

« назад - далее »

Rita

Всем привет!
Помогите, пожалуйста, подправить макрос. Его суть: создаетя книга-копия исходника с очищенным форматированием за пределами данных, внесенных на лист. Это помогает значительно "облегчить" файл.
При его выполнении слетают закрепления областей, фильтры, группировка строк и появляется сетка (если она была скрыта).

Option Explicit
Option Base 1
Sub ReduceSize()
Dim LastRow As Long
Dim LastColumn As Integer
Dim arrRowHeight() As Single
Dim arrColumnWidth() As Single
Dim newWbk As Workbook
Dim oldWbName As String
Dim newWbName As String
Dim WbPath As String
Dim ShtName As String
Dim Sht As Worksheet
Dim n As Integer
Dim i As Integer
oldWbName = ActiveWorkbook.Name ' запомним имя старой книги
WbPath = ActiveWorkbook.Path ' запомним путь к старой книге
Set newWbk = Workbooks.Add ' создадим новую книгу (она сразу станет ActiveWorkbook)
ActiveWorkbook.SaveAs WbPath & "\" & "(NEW) " & oldWbName 'сохраним новую книгу рядом со старой с префиксом к имени "(NEW) "
newWbName = ActiveWorkbook.Name ' запомним имя новой книги
i = 1 ' начинаем с первой страницы новой книги
For Each Sht In Workbooks(oldWbName).Sheets ' цикл по всем листам старой книги
Sht.Activate
With ActiveSheet
ShtName = .Name
LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' последняя строка на листе, содержащая хоть какие-нибудь значения
LastColumn = .Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' последний столбец на листе, содержащий хоть какие-нибудь значения
ReDim arrRowHeight(LastRow)
ReDim arrColumnWidth(LastColumn)
For n = 1 To LastRow ' запомним высоты строк в массив
arrRowHeight(n) = .Rows(n).RowHeight
Next n
For n = 1 To LastColumn ' запомним ширины столбцов в массив
arrColumnWidth(n) = .Columns(n).ColumnWidth
Next n
Application.CutCopyMode = False
Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy ' копируем только диапазон, содержащий данные
End With
With Workbooks(newWbName)
If .Sheets.Count < i Then .Sheets.Add after:=.Sheets(.Sheets.Count)
.Sheets(i).Name = ShtName
.Sheets(i).Paste ' копируем на страницу новой книги диапазон, содержащий данные
Application.CutCopyMode = False
For n = 1 To LastRow ' восстановим высоты строк
.Sheets(i).Rows(n).RowHeight = arrRowHeight(n)
Next n
For n = 1 To LastColumn ' восстановим ширины столбцов
.Sheets(i).Columns(n).ColumnWidth = arrColumnWidth(n)
Next n
End With
i = i + 1 ' продолжим на следующей странице новой книги
Next
Application.DisplayAlerts = False
Call ExportAllStdModules(newWbk, Workbooks(oldWbName)) ' скопировать все компоненты VBA в новую книгу
Workbooks(newWbName).Save
Workbooks(oldWbName).Close savechanges:=True
Application.DisplayAlerts = True
End Sub

Оформляйте код тегами! Модератор.

NooBasTiK

Вы бы лучше приложили файл с примером, так быстрее ответят

Rita

#2
Дело в том, что я применяю этот макрос к файлу, где более 1300 листов, которые, естественно, являются ком.тайной.
Этот макрос можно применять к любым файлам. Конечно, к файлу из одного листа нет смысла его применять из-за нерациональности. Но для пробы можно, дабы понять, как это работает.
Сделала совсем простой пример. Запустила сл.макрос (нашла у себя в заметках - он немного дополнен):
Option Explicit
Option Base 1
Sub ReduceSize()
Dim LastRow As Long
Dim LastColumn As Integer
Dim arrRowHeight() As Single
Dim arrColumnWidth() As Single
Dim newWbk As Workbook
Dim oldWbName As String
Dim newWbName As String
Dim WbPath As String
Dim ShtName As String
Dim Sht As Worksheet
Dim n As Integer
Dim i As Integer
oldWbName = ActiveWorkbook.Name ' запомним имя старой книги
WbPath = ActiveWorkbook.Path ' запомним путь к старой книге
Set newWbk = Workbooks.Add ' создадим новую книгу (она сразу станет ActiveWorkbook)
ActiveWorkbook.SaveAs WbPath & "\" & "(NEW) " & oldWbName 'сохраним новую книгу рядом со старой с префиксом к имени "(NEW) "
newWbName = ActiveWorkbook.Name ' запомним имя новой книги
i = 1 ' начинаем с первой страницы новой книги
For Each Sht In Workbooks(oldWbName).Sheets ' цикл по всем листам старой книги
Sht.Activate
With ActiveSheet
ShtName = .Name
LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' последняя строка на листе, содержащая хоть какие-нибудь значения
LastColumn = .Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' последний столбец на листе, содержащий хоть какие-нибудь значения
ReDim arrRowHeight(LastRow)
ReDim arrColumnWidth(LastColumn)
For n = 1 To LastRow ' запомним высоты строк в массив
arrRowHeight(n) = .Rows(n).RowHeight
Next n
For n = 1 To LastColumn ' запомним ширины столбцов в массив
arrColumnWidth(n) = .Columns(n).ColumnWidth
Next n
Application.CutCopyMode = False
Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy ' копируем только диапазон, содержащий данные
End With
With Workbooks(newWbName)
If .Sheets.Count < i Then .Sheets.Add after:=.Sheets(.Sheets.Count)
.Sheets(i).Name = ShtName
.Sheets(i).Paste ' копируем на страницу новой книги диапазон, содержащий данные
Application.CutCopyMode = False
For n = 1 To LastRow ' восстановим высоты строк
.Sheets(i).Rows(n).RowHeight = arrRowHeight(n)
Next n
For n = 1 To LastColumn ' восстановим ширины столбцов
.Sheets(i).Columns(n).ColumnWidth = arrColumnWidth(n)
Next n
End With
i = i + 1 ' продолжим на следующей странице новой книги
Next
Application.DisplayAlerts = False
Call ExportAllStdModules(newWbk, Workbooks(oldWbName)) ' скопировать все компоненты VBA в новую книгу
Workbooks(newWbName).Save
Workbooks(oldWbName).Close savechanges:=True
Application.DisplayAlerts = True
End Sub
Private Sub ExportAllStdModules(newWbk As Workbook, oldWbk As Workbook) ' скопировать все компоненты VBA в новую книгу
Dim iTempPath As String, iModuleName As String
Dim iVBComponent As Object
Dim a As Boolean
With Application
.ScreenUpdating = False
iTempPath = .DefaultFilePath & .PathSeparator
With newWbk.VBProject.VBComponents
For Each iVBComponent In oldWbk.VBProject.VBComponents
iModuleName$ = iTempPath$ & iVBComponent.Name
a = CopyModule(iVBComponent.Name, _
oldWbk.VBProject, _
newWbk.VBProject, True)
Next
End With
.ScreenUpdating = True
End With
End Sub
Function CopyModule(ModuleName As String, _
FromVBProject, _
ToVBProject, _
OverwriteExisting As Boolean) As Boolean
Dim VBComp As Object 'As VBIDE.VBComponent
Dim FName$, CompName$, S$
Dim SlashPos&, ExtPos&
Dim TempVBComp 'As VBIDE.VBComponent
Dim vbext_pp_locked As Boolean
On Error Resume Next
Set VBComp = FromVBProject.VBComponents(ModuleName)
If Err.Number <> 0 Then
CopyModule = False
Exit Function
End If
FName = Environ("Temp") & "\" & ModuleName & ".bas"
If OverwriteExisting = True Then
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
CopyModule = False
Exit Function
End If
End If
With ToVBProject.VBComponents
.Remove .Item(ModuleName)
End With
Else
Err.Clear
Set VBComp = ToVBProject.VBComponents(ModuleName)
If Err.Number <> 0 Then
If Err.Number = 9 Then
' module doesn't exist. ignore error.
Else
' other error. get out with return value of False
CopyModule = False
Exit Function
End If
End If
End If
FromVBProject.VBComponents(ModuleName).Export Filename:=FName
SlashPos = InStrRev(FName, "\")
ExtPos = InStrRev(FName, ".")
CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
Set VBComp = Nothing
Set VBComp = ToVBProject.VBComponents(CompName)
If VBComp Is Nothing Then
ToVBProject.VBComponents.Import Filename:=FName
Else
Set TempVBComp = ToVBProject.VBComponents.Import(FName)
' TempVBComp is source module
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
.InsertLines 1, S
End With
On Error GoTo 0
ToVBProject.VBComponents.Remove TempVBComp
End If
Kill FName
CopyModule = True
End Function

Оформляйте код тегами! Модератор.

Хоть Excel и ругается на что-то (я не сильна в макросах, поэтому не знаю, на что  :) ), но макрос выполнился, и проблемы с форматами остались.

kuklp

Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Rita

Да, Вы правы. Код взят именно оттуда.
Но, насколько я помню, там он в таком варианте и остался. Проблема форматов не исчезла.
Поэтому я подняла эту тему здесь.

kuklp

Интересная логика.  :o А почему не там? Но дело Ваше.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Rita

Женская логика, как известно, вообще штука сложная   ::)
Зарегистрирована на этом форуме, нравится, как отвечают. На все мои вопросы до, получила необходимые ответы. Могу еще долго расхваливать этот форум, но, думаю тогда надо создать отдельную "Хвалебную" тему.  ;)