Вернуть Excel листам первозданный вид макросом

vadim245 · 28 ноя 2012, 14:46

Коллеги, поделитесь макросом, если есть у кого или помогите pls.
Нужно, чтобы все листы в присылаемых мне каждый раз файлах не содержали рюшечек.
Нужно макросом:

- убрать все кнопки
- раскрыть и отменить все группировки
- показать все скрытые строки
- очистить все фильтры
- вместо формул вставить везде только значения
- отменить объединение всех ячеек
- размер всех строк и столбцов сделать дефолтным
- наконец убить все связи

Спасибо.

pashulka · 28 ноя 2012, 20:48

Код: Выделить всё

Private Sub Test()
    Application.ScreenUpdating = False

    Dim iList As Worksheet
    For Each iList In ActiveWorkbook.Worksheets
        With iList
             .DrawingObjects.Delete '.OLEObjects.Delete: .Buttons.Delete
             '- убрать все кнопки (в т.ч. и все остальные графические об'екты)
             If .FilterMode = True Then .ShowAllData
             '- очистить все фильтры (меню Данные - Фильтр - Отобразить все)
             With .UsedRange
                  .ClearOutline
                  '- раскрыть и отменить все группировки (меню Данные - Группа и Структура - Удалить структуру)
                  .Rows.Hidden = False
                  '- показать все скрытые строки (меню Формат - Строка - Отобразить)
                  .Value = .Value
                  '- вместо формул вставить везде только значения (можно также использовать специальную вставку)
                  .MergeCells = False
                  '- отменить объединение всех ячеек (меню Формат - Ячейки - Выравнивание - снять флажок Объединение ячеек)
                  .Rows.UseStandardHeight = True
                  .Columns.UseStandardWidth = True
                  '- размер всех строк и столбцов сделать дефолтным
             End With
        End With
    Next
    
    Application.ScreenUpdating = True
End Sub

Что касается разрыва связей, то если замены формул на их значения окажется недостаточным, то начиная с Excel XP можно использовать

Код: Выделить всё

ActiveWorkbook.BreakLink(Name As String, Type As XlLinkType)

vadim245 · 29 ноя 2012, 07:41

WOW :-) спасибо большое!

vadim245 · 29 ноя 2012, 09:51

Подскажите пожалуйста, почему при использовании макроса с вызовом его из основного возникает ошибка на строчке .ClearOutline. В текущем каталоге берется первый файл, в нем успешно находится нужный лист, отлично вся структура приводится к девственному виду. Копируется всё, что есть на листе (в заведомо большей зоне, чем нужно) и переносится в книгу с макросом на нужный лист. При переходе на следующий файл подпрограмма-макрос валится.
Где у меня косяк? Как сделать, чтоб сборкой обработались все документы в каталоге с предварительной обработкой макросом-подпрограммой?

' Макрос собирает на лист "Сборник" со всех листов "Готовый лист" всех файлов, которые находятся в текущей диретории

Sub sborka2()
Dim iPath As String, iFileName As String, TxtFile As Workbook
Dim OrigWB As Workbook

Set OrigWB = ActiveWorkbook ' Книга в которую будем все собирать

iPath = ThisWorkbook.Path & Application.PathSeparator
iFileName = Dir(iPath & "*.xls*")

Do While iFileName <> ""
If iFileName <> ThisWorkbook.Name Then
Set TxtFile = Workbooks.Open(Filename:=iPath & iFileName)

Set TxtFile = ActiveWorkbook
Run ("Macro.xlsm!Test")
lastrow = OrigWB.Worksheets("Сборник").Cells.SpecialCells(xlLastCell).Row
' Сборник - это лист того файла куда собираем все
TxtFile.Worksheets("NewDataSource").Range("A1:AQ3200").Copy Destination:=OrigWB.Sheets("Сборник").Cells(lastrow + 1, 1)
' "NewDataSource" - одинаковое название листа во всех файлах "A1:AQ3200" - область которую копируем
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
End If
iFileName = Dir
Loop
End Sub

Private Sub Test()
Application.ScreenUpdating = False

Dim iList As Worksheet
For Each iList In ActiveWorkbook.Worksheets
With iList
.DrawingObjects.Delete '.OLEObjects.Delete: .Buttons.Delete
'- убрать все кнопки (в т.ч. и все остальные графические об'екты)
If .FilterMode = True Then .ShowAllData
'- очистить все фильтры (меню Данные - Фильтр - Отобразить все)
With .UsedRange

'- раскрыть и отменить все группировки (меню Данные - Группа и Структура - Удалить структуру)
.Rows.Hidden = False
'- показать все скрытые строки (меню Формат - Строка - Отобразить)
.Value = .Value
'- вместо формул вставить везде только значения (можно также использовать специальную вставку)
.MergeCells = False
'- отменить объединение всех ячеек (меню Формат - Ячейки - Выравнивание - снять флажок Объединение ячеек)
.Rows.UseStandardHeight = True
.Columns.UseStandardWidth = True
'- размер всех строк и столбцов сделать дефолтным
End With
End With
Next

Application.ScreenUpdating = True

End Sub

pashulka · 29 ноя 2012, 19:31

Давайте попробуем использовать что-то вроде нижеопубликованного варианта, не забывая, что рабочие листы, над которыми производятся надругательства, т.е. те которым возвращается первозданный вид, не должны быть защищены, иначе возникнет ошибка.

Код: Выделить всё

Private Sub Sborka2()
    Dim iPath$, iFileName$, iLastRow&
    Dim iSourceWB As Workbook, iTargetWB As Workbook

    Set iTargetWB = ActiveWorkbook ' Книга в которую будем все собирать

    iPath = ThisWorkbook.Path & Application.PathSeparator
    iFileName = Dir(iPath & "*.xls*")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    'и т.д. по необходимости

    Do While iFileName <> ""
       If iFileName <> iTargetWB.Name Then
          Set iSourceWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=0)

          RestoreDefaultWS iSourceWB
          
          iLastRow = iTargetWB.Worksheets("Сборник").[A1].SpecialCells(xlLastCell).Row
          'Сборник - это лист того файла куда собираем все
          iSourceWB.Worksheets("NewDataSource").UsedRange.Copy Destination:=iTargetWB.Worksheets("Сборник").Cells(iLastRow + 1, 1)
          '"NewDataSource" - одинаковое название листа во всех файлах
          iSourceWB.Close saveChanges:=False
       End If
       iFileName = Dir
    Loop
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Private Sub RestoreDefaultWS(iSourceWB As Workbook)
    Dim iList As Worksheet
    For Each iList In iSourceWB.Worksheets
        With iList
             .DrawingObjects.Delete '.OLEObjects.Delete: .Buttons.Delete
             '- убрать все кнопки (в т.ч. и все остальные графические об'екты)
             If .FilterMode = True Then .ShowAllData
             '- очистить все фильтры (меню Данные - Фильтр - Отобразить все)
             With .UsedRange
                  .ClearOutline
                  '- раскрыть и отменить все группировки (меню Данные - Группа и Структура - Удалить структуру)
                 .Rows.Hidden = False
                 '- показать все скрытые строки (меню Формат - Строка - Отобразить)
                 .Value = .Value
                 '- вместо формул вставить везде только значения (можно также использовать специальную вставку)
                 .MergeCells = False
                 '- отменить объединение всех ячеек (меню Формат - Ячейки - Выравнивание - снять флажок Объединение ячеек)
                .Rows.UseStandardHeight = True
                .Columns.UseStandardWidth = True
                '- размер всех строк и столбцов сделать дефолтным
             End With
        End With
   Next
End Sub

Правда остаётся открытым вопрос, а зачем возвращать всем рабочим листам первозданный вид, если копируются ячейки одного листа, а именно "NewDataSource"

vadim245 · 30 ноя 2012, 08:16

pashulka писал(а):....не должны быть защищены, иначе возникнет ошибка.
Правда остаётся открытым вопрос, а зачем возвращать всем рабочим листам первозданный вид, если копируются ячейки одного листа, а именно "NewDataSource"

1. Потому что мозгов маловато у меня :-).
2. Сперва будут руками открыто 40 файлов и запущен макрос. который убивает защиты поочередно в каждом и закрывает с сохранением. Поэтому проблем у Вашего макроса не будет.
3. Потом будут запущен как раз Ваш макрос 4 раза последовательно. Каждый отличается только типовым именем листа, с которого данные будут собираться и именем листа - назначения.
В итоге данные соберутся из 4 типовых листов всех файлов и склеятся нв книге с макросом. Понимаю. что половина работы макросами будет порожняковая, но программист из меня никудышный.

Вот этот макрос снимает защиты с файлов у меня[ATTACH]1542[/ATTACH]

pashulka · 30 ноя 2012, 08:27

Для того, чтобы закрыть книгу сохранив изменения, необходимо заменить False на True, т.е

Код: Выделить всё

iSourceWB.Close saveChanges:=True

vadim245 · 30 ноя 2012, 08:36

pashulka писал(а):Для того, чтобы закрыть книгу сохранив изменения, необходимо заменить False на True, т.е
Код: Выделить всё
iSourceWB.Close saveChanges:=True

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

pashulka · 30 ноя 2012, 19:27

Таки да

pashulka · 01 дек 2012, 08:48

Вернёмся к нашим баранам, в смысле макросам :

2) Проблем с защитой листа вообще не будет, если Вы знаете пароль для "отключения" защиты листа или Вы будете использовать Excel 97 или 2000. В противном случае, снимать защиту листа можно после открытия рабочей книги, т.е. в цикле Do While … Loop (это позволит Вам обойтись без открытия книг вручную)
3) Если исходные рабочие книги содержат, минимум, по четыре рабочих листа, и в книге-сборнике их будет не меньше, то можно обойтись и без последовательного запуска макроса аж 4 раза, например :

Код: Выделить всё

Private Sub Sborka3()
    Dim iLastRow&, iCount%
    Dim iPath$, iFileName$
    'Dim iSourceWS$, iTargetWS$
    Dim iSourceWB As Workbook, iTargetWB As Workbook

    Set iTargetWB = ActiveWorkbook ' Книга в которую будем все собирать

    iPath = ThisWorkbook.Path & Application.PathSeparator
    iFileName = Dir(iPath & "*.xls*")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    'и т.д. по необходимости

    Do While iFileName <> ""
       If iFileName <> iTargetWB.Name Then
          Set iSourceWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=0)

          RestoreDefaultWS iSourceWB
         
          For iCount = 1 To 4
              iLastRow = iTargetWB.Worksheets(iCount).[A1].SpecialCells(xlLastCell).Row
              iSourceWB.Worksheets(iCount).UsedRange.Copy Destination:=iTargetWB.Worksheets(iCount).Cells(iLastRow + 1, 1)
          Next
          
          iSourceWB.Close saveChanges:=True 'False
          'если книги-источники в дальнейшем использоваться не будут, то изменения можно и не сохранять ...
       End If
       iFileName = Dir
    Loop
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Private Sub RestoreDefaultWS(iSourceWB As Workbook)
    Dim iList As Worksheet
    For Each iList In iSourceWB.Worksheets
        With iList
             .DrawingObjects.Delete '.OLEObjects.Delete: .Buttons.Delete
             '- убрать все кнопки (в т.ч. и все остальные графические об'екты)
             If .FilterMode = True Then .ShowAllData
             '- очистить все фильтры (меню Данные - Фильтр - Отобразить все)
             With .UsedRange
                  .ClearOutline
                  '- раскрыть и отменить все группировки (меню Данные - Группа и Структура - Удалить структуру)
                 .Rows.Hidden = False
                 '- показать все скрытые строки (меню Формат - Строка - Отобразить)
                 .Value = .Value
                 '- вместо формул вставить везде только значения (можно также использовать специальную вставку)
                 .MergeCells = False
                 '- отменить объединение всех ячеек (меню Формат - Ячейки - Выравнивание - снять флажок Объединение ячеек)
                .Rows.UseStandardHeight = True
                .Columns.UseStandardWidth = True
                '- размер всех строк и столбцов сделать дефолтным
             End With
        End With
    Next
End Sub

Если использования индекса(номера) листа нежелательно, то, разумеется, в макросе можно указать и имя листа, с которого данные будут собираться и имя листа - назначения.