Option Explicit
Option Base 1

Sub ReduceSize() ' фитнесс для разбухших файлов
'---------------------------------------------------------------------------------------
' Procedure : ReduceSize
' Author    : KuklP + Alex_ST ("полировка" и комментарии)
' URL       : http://www.excelworld.ru/forum/3-57-1
' Date      : 10.09.2010 + 01.02.2011
' Purpose   : фитнесс для разбухших файлов
'---------------------------------------------------------------------------------------

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

Private Sub ExportAllStdModules(wb As Workbook) ' скопировать все компоненты VBA в новую книгу
       Dim iTempPath$, iModuleName$
       Dim iVBComponent
       With Application
           .ScreenUpdating = False
           iTempPath = .DefaultFilePath & .PathSeparator
           With wb.VBProject.VBComponents
               For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
                   If iVBComponent.Type = 1 Then
                       iModuleName$ = iTempPath$ & iVBComponent.Name
                       iVBComponent.Export Filename:=iModuleName$
                       .Import Filename:=iModuleName$
                       Kill PathName:=iModuleName$
                   End If
               Next
           End With
           .ScreenUpdating = True
       End With
End Sub

With newWb        
       If .Sheets.Count < i Then .Sheets.Add after:=.Sheets.Count

With newWb
       If .Sheets.Count < i Then   .Sheets.Add after:=.Sheets(.Sheets.Count)

If .Sheets.Count < i Then .Sheets.Add ' after:=.Sheets.Count

If iVBComponent.Type = 1 Then

If iVBComponent.Type = vbext_ct_StdModule Then

For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
'If iVBComponent.Type = 1 Then
iModuleName$ = iTempPath$ & iVBComponent.Name
iVBComponent.Export Filename:=iModuleName$
.Import Filename:=iModuleName$
Kill PathName:=iModuleName$
'End If
Next

Sub ReduceSize()
      Dim lAntR As Long
      Dim iAntK As Integer
      Dim aR() As Single
      Dim aK() As Single
      Dim n As Integer
      Dim sFil1 As String
      Dim sFil2 As String
      Dim sKat As String
      Dim sArk As String
      Dim sh As Worksheet
      Dim nWb As Workbook
      Dim i As Integer
      i = 1
      sFil1 = ActiveWorkbook.Name
      sKat = ActiveWorkbook.Path
      Set nWb = Workbooks.Add
      sFil2 = ActiveWorkbook.Name
      Workbooks(sFil2).SaveAs sKat & "\" & "(2)" & sFil1
      sFil2 = ActiveWorkbook.Name
      For Each sh In ThisWorkbook.Sheets
          sh.Activate
          sArk = ActiveSheet.Name
          lAntR = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
          iAntK = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

          ReDim aR(lAntR)
          ReDim aK(iAntK)
          For n = 1 To lAntR
              aR(n) = Rows(n).RowHeight
          Next n
          For n = 1 To iAntK
              aK(n) = Columns(n).ColumnWidth
          Next n
          Application.CutCopyMode = False
          Range(sh.Cells(1, 1), sh.Cells(lAntR, iAntK)).Copy
          With nWb
              If .Sheets.Count < i Then
                  .Sheets.Add after:=.Sheets(.Sheets.Count)
              End If
              .Sheets(i).Name = sArk
              .Sheets(i).Paste    '([a1])
              Application.CutCopyMode = False
              For n = 1 To lAntR
                  .Sheets(i).Rows(n).RowHeight = aR(n)
              Next n
              For n = 1 To iAntK
                  .Sheets(i).Columns(n).ColumnWidth = aK(n)
              Next n
          End With
          i = i + 1
      Next
      Application.DisplayAlerts = False
      Call ExportAllStdModules(Workbooks(sFil2))
      Workbooks(sFil2).Save
      Workbooks(sFil1).Close savechanges:=True
      Application.DisplayAlerts = True
End Sub
Private Sub ExportAllStdModules(wb As Workbook)
      Dim iTempPath As String, iModuleName As String
      Dim iVBComponent As Object
      Dim a As Boolean
      With Application
          .ScreenUpdating = False
          iTempPath = .DefaultFilePath & .PathSeparator
          With wb.VBProject.VBComponents
              For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
                  iModuleName$ = iTempPath$ & iVBComponent.Name
                  a = CopyModule(iVBComponent.Name, _
                     ThisWorkbook.VBProject, _
                     wb.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

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

Public Sub www()
Dim Sh As Object, iCodeName$
For Each Sh In Sheets
iCodeName = Sh.CodeName
Application.VBE.ActiveVBProject.VBComponents(iCodeName).Name = Sh.Name
Next
End Sub