Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сводные таблицы в обычные
 
#1
13.12.2024 14:28:10
Всем добрый день! Прошу помочь мне избавиться от муторного дела — копирования сводных таблиц и превращения их в обычные. Я очень часто пользуюсь сводными таблицами, но мне нужно постоянно преобразовывать их в обычные. Я копирую сводную таблицу, исключая итоговую строку, и затем вставляю её, только так я могу избавиться от сводной. Может быть, есть макрос, который возьмёт все сводные таблицы в открытой книге и сделает их обычными? этот макрос не работает..

Sub ConvertPivotTablesToValues()
   Dim ws As Worksheet
   Dim pt As PivotTable
   Dim finalRange As Range
   
   ' Проходим по каждой вкладке в книге
   For Each ws In ThisWorkbook.Worksheets
       ' Проходим по каждой сводной таблице на листе
       For Each pt In ws.PivotTables
           ' Копируем данные сводной таблицы
           pt.TableRange2.Copy
           
           ' Вставляем как значения
           Set finalRange = pt.TableRange2.Cells(1, 1)
           finalRange.PasteSpecial Paste:=xlPasteValues
           
           ' Очистка буфера обмена
           Application.CutCopyMode = False
       Next pt
   Next ws
   
   MsgBox "Все сводные таблицы были успешно преобразованы в обычные значения!"
End Sub
 
 
 
#2
13.12.2024 14:51:48
Цитата
Евгения написал: этот макрос не работает.
Этот макрос работает
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
13.12.2024 15:03:58
  - Set finalRange = pt.TableRange2.Cells(1, 1) — определяет диапазон (первую ячейку) для вставки значений. Он только столбец А обрабатывает
 
 
 
#4
13.12.2024 15:10:35
Что Вы имеете ввиду?
Цитата
Евгения написал: Он только столбец А обрабатывает
Т.е. если Сводная расположена правее столбца 'A' она не обрабатывается?
В Вашем файле таких нет, но специально вставил столбцы(разное кол-во) слева от Сводных и макрос отработал без проблем
П.С. не мешает добавить отключение экрана, но в целом проблем не увидел
Согласие есть продукт при полном непротивлении сторон
 
 
 
#5
13.12.2024 15:13:46
у меня он обрабатывает только столбец А, все другие  пишет, Мы не можем изменить этц часть сводной таблицы.
Изменено: Евгения - 13.12.2024 15:14:26
 
 
 
#6
13.12.2024 15:15:13
На этом же файле?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
13.12.2024 15:22:15
Да, я хочу чтобы все сводные были просто редактируемые ячейками
 
 
 
#8
13.12.2024 15:27:05
Попробуйте в этом файле. Нажмите на кнопку
Согласие есть продукт при полном непротивлении сторон
 
 
 
#9
13.12.2024 16:01:45
Вообще не понимаю, вставляю это код в свою личную книгу, не работает, а у Вас работает  Sub ConvertPivotTablesToValues()
  Dim ws As Worksheet
  Dim pt As PivotTable
  Dim finalRange As Range
  Application.ScreenUpdating = False
  ' Проходим по каждой вкладке в книге
  For Each ws In ThisWorkbook.Worksheets
      ' Проходим по каждой сводной таблице на листе
      For Each pt In ws.PivotTables
          ' Копируем данные сводной таблицы
          pt.TableRange2.Copy
         
          ' Вставляем как значения
          Set finalRange = pt.TableRange2.Cells(1, 1)
          finalRange.PasteSpecial Paste:=xlPasteValues
         
          ' Очистка буфера обмена
          Application.CutCopyMode = False
      Next pt
      ws.Activate
      ws.Range("A1").Select
  Next ws
  ThisWorkbook.Worksheets(1).Activate
  Application.ScreenUpdating = True
  MsgBox "Все сводные таблицы были успешно преобразованы в обычные значения!"
'   Call Удаление_запросов
End Sub

'Sub Удаление_запросов()
'    If MsgBox("Удалить все запросы из активной книги?", vbQuestion + vbYesNo, "Удаление запросов") = vbNo Then Exit Sub
'    Dim pq As Object
'    For Each pq In ActiveWorkbook.Queries
'        pq.Delete
'    Next
'    MsgBox "Все запросы из активной книги удалены!", vbInformation, "Удаление запросов"
'End Sub
 
 
 
#10
13.12.2024 16:05:54
Евгения,
Цитата
написал:
свою личную книгу
Это случайно не Личная книга макросов? Если да, то работать не будет, т.к. в коде ссылка на ThisWorkbook, тогда нужно заменить на ActiveWorkbook
 
 
 
#11
13.12.2024 16:07:42
Я поэтому и спрашивал
Цитата
Sanja написал: На этом же файле?
В реальном файле, видимо, структура другая.
Возможно есть Сводные, расположенные рядом друг с другом, а не под друг другом
Согласие есть продукт при полном непротивлении сторон
 
 
 
#12
13.12.2024 16:08:42
Цитата
Alex написал: Это случайно не Личная книга макросов?
Да, об этом тоже нужно сразу предупреждать
Согласие есть продукт при полном непротивлении сторон
 
 
 
#13
13.12.2024 16:11:41
ОТЛИЧНО!!!а ПОЧЕМУ НЕ РАБОТАЕТ УСЛОВИЕ, ЧТОБЫ ФОРМАТИРОВАНИЕ СОХРАНИЛОСЬ

Sub ConvertPivotTablesToValues()
   Dim ws As Worksheet
   Dim pt As PivotTable
   Dim finalRange As Range
   Application.ScreenUpdating = False

   ' Проходим по каждой вкладке в книге
   For Each ws In ActiveWorkbook.Worksheets
       ' Проходим по каждой сводной таблице на листе
       For Each pt In ws.PivotTables
           ' Копируем данные сводной таблицы с сохранением форматирования
           pt.TableRange2.Copy
           
           ' Устанавливаем конечный диапазон
           Set finalRange = pt.TableRange2.Cells(1, 1)
           
           ' Вставляем как значения
           finalRange.PasteSpecial Paste:=xlPasteValues
           
           ' Вставляем форматирование
           finalRange.PasteSpecial Paste:=xlPasteFormats
           
           ' Очистка буфера обмена
           Application.CutCopyMode = False
       Next pt
   Next ws

   Application.ScreenUpdating = True
   MsgBox "Все сводные таблицы были успешно преобразованы в обычные значения!"
   ' Call Удаление_запросов
End Sub

'Sub Удаление_запросов()
'    If MsgBox("Удалить все запросы из активной книги?", vbQuestion + vbYesNo, "Удаление запросов") = vbNo Then Exit Sub
'    Dim pq As Object
'    For Each pq In ActiveWorkbook.Queries
'        pq.Delete
'    Next
'    MsgBox "Все запросы из активной книги удалены!", vbInformation, "Удаление запросов"
'End Sub
 
 
 
#14
13.12.2024 16:14:58
Евгения, код в сообщении оформляйте соответствующим тэгом (<...>). Исправьте свои сообщения
Согласие есть продукт при полном непротивлении сторон
 
 
 
#15
13.12.2024 16:17:51
Потому что в Сводной не обычное форматирование, а Стили
Согласие есть продукт при полном непротивлении сторон
 
 
 
#16
14.12.2024 15:09:49
Спасибо большое, я тут попыталась код отредактировать, не успех не пришел..Изменен параметр Paste в методе PasteSpecial на xlPasteAllUsingSourceTheme, что позволяет сохранить стиль и форматирование при вставке значений



<<Sub ConvertPivotTablesToValues()
 Dim ws As Worksheet
 Dim pt As PivotTable
 Dim finalRange As Range
 Application.ScreenUpdating = False
 ' Проходим по каждой вкладке в книге
 For Each ws In ActiveWorkbook.Worksheets
     ' Проходим по каждой сводной таблице на листе
     For Each pt In ws.PivotTables
         ' Копируем данные сводной таблицы
         pt.TableRange2.Copy
       
         ' Вставляем как значения с сохранением стиля
         Set finalRange = pt.TableRange2.Cells(1, 1)
         finalRange.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
       
         ' Очистка буфера обмена
         Application.CutCopyMode = False
     Next pt
     ws.Activate
     ws.Range("A1").Select
 Next ws
 ThisWorkbook.Worksheets(1).Activate
 Application.ScreenUpdating = True
 MsgBox "Все сводные таблицы были успешно преобразованы в обычные значения!"
'   Call Удаление_запросов
End Sub

'Sub Удаление_запросов()
'    If MsgBox("Удалить все запросы из активной книги?", vbQuestion + vbYesNo, "Удаление запросов") = vbNo Then Exit Sub
'    Dim pq As Object
'    For Each pq In ActiveWorkbook.Queries
'        pq.Delete
'    Next
'    MsgBox "Все запросы из активной книги удалены!", vbInformation, "Удаление запросов"
'End Sub >>
 
 
 
#17
14.12.2024 15:23:02
Цитата
Евгения написал:
End Sub >>
Это не тэг для кода)))
См. на панели сообщений
И закомментированный кусок кода можно удалить (Про удаление запросов). Это я Ваш файл чистил, что-бы полегче стал
Примерно так
Код
Sub ConvertPivotTablesToValues()
 Dim ws As Worksheet
 Dim pt As PivotTable
 Dim finalRange As Range
 Application.ScreenUpdating = False
 ' Проходим по каждой вкладке в книге
 For Each ws In ActiveWorkbook.Worksheets
     ' Проходим по каждой сводной таблице на листе
     For Each pt In ws.PivotTables
         ' Копируем данные сводной таблицы
         pt.TableRange2.Copy
       
         ' Вставляем как значения с сохранением стиля
         Set finalRange = pt.TableRange2.Cells(1, 1)
         finalRange.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
       
         ' Очистка буфера обмена
         Application.CutCopyMode = False
     Next pt
     ws.Activate
     ws.Range("A1").Select
 Next ws
 ThisWorkbook.Worksheets(1).Activate
 Application.ScreenUpdating = True
 MsgBox "Все сводные таблицы были успешно преобразованы в обычные значения!"
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
Страницы: 1
Наверх