Спасибо огромное, все работает идеально!

Это я своем коде, заменить функцию на вашу?

Всем привет, у меня есть такая потребность, создание папок и подпапок  1 столбец это главная папка, 2 столбец это подпапки. Но код не совсем работает  Sub CreateFoldersAndSubfoldersWithUserInput()
'Updateby Extendoffice
   Dim Rng As Range
   Dim Cell As Range
   Dim basePath As String
   Dim fldrPicker As FileDialog
   Dim FolderPath As String, subfolderPath As String
   On Error Resume Next
   Set Rng = Application.InputBox("Select the range of cells (two columns: one is folder column, another s subfolder column):", "Kutools for Excel", Type:=8)
   If Rng Is Nothing Then Exit Sub
   On Error GoTo 0
   Set fldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
   With fldrPicker
       .Title = "Select the Base Folder Path"
       .AllowMultiSelect = False
       If .Show <> -1 Then Exit Sub
       basePath = .SelectedItems(1)
   End With
   If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
   For Each Cell In Rng.Columns(1).Cells
       If Not Cell.Value = "" Then
           FolderPath = basePath & Cell.Value
           If Not FolderExists(FolderPath) Then MkDir FolderPath
           If Not Cell.Offset(0, 1).Value = "" Then
               subfolderPath = FolderPath & "\" & Cell.Offset(0, 1).Value
               If Not FolderExists(subfolderPath) Then MkDir subfolderPath
           End If
       End If
   Next Cell
End Sub

Function FolderExists(FolderPath As String) As Boolean
   On Error Resume Next
   FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
   On Error GoTo 0
End Function

Спасибо большое, я тут попыталась код отредактировать, не успех не пришел..Изменен параметр 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 >>

ОТЛИЧНО!!!а ПОЧЕМУ НЕ РАБОТАЕТ УСЛОВИЕ, ЧТОБЫ ФОРМАТИРОВАНИЕ СОХРАНИЛОСЬ

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

Вообще не понимаю, вставляю это код в свою личную книгу, не работает, а у Вас работает  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

Да, я хочу чтобы все сводные были просто редактируемые ячейками

у меня он обрабатывает только столбец А, все другие  пишет, Мы не можем изменить этц часть сводной таблицы.

  - Set finalRange = pt.TableRange2.Cells(1, 1) — определяет диапазон (первую ячейку) для вставки значений. Он только столбец А обрабатывает

Всем добрый день! Прошу помочь мне избавиться от муторного дела — копирования сводных таблиц и превращения их в обычные. Я очень часто пользуюсь сводными таблицами, но мне нужно постоянно преобразовывать их в обычные. Я копирую сводную таблицу, исключая итоговую строку, и затем вставляю её, только так я могу избавиться от сводной. Может быть, есть макрос, который возьмёт все сводные таблицы в открытой книге и сделает их обычными? этот макрос не работает..

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

прошу прощения!!! проверила, все работает

Помогите, пожалуйста,

Соглашение   о компенсации Соглашение   ПП-333

Добрый день, прошу исправить макрос, который группирует строки с жирным цветом, а вот эти не группирует


Sub GroupByBoldAndNonBold()
   Dim iLastRow As Long, lStart As Long
   Dim i As Long
   Application.ScreenUpdating = False
   
   ' Определяем последнюю строку с данными в первом столбце
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   lStart = 1
   
   ' Проходим по всем строкам до последней
   For i = 1 To iLastRow
       If Cells(i, 1).Font.Bold Then
           ' Если встречаем жирную строку и lStart меньше текущей строки
           If lStart < i Then
               ' Группируем нежирные строки между жирными
               Range(Cells(lStart, 1), Cells(i - 1, 1)).EntireRow.Group
           End If
           ' Обновляем lStart на следующую строку после жирной
           lStart = i + 1
       End If
   Next i
   
   ' Проверяем, есть ли нежирные строки после последней жирной строки
   If lStart <= iLastRow Then
       Range(Cells(lStart, 1), Cells(iLastRow, 1)).EntireRow.Group
   End If
   
   Application.ScreenUpdating = True
End Sub

а если так Option Explicit
Sub ОбъединенныйМакрос()
  ' Вызов первой части макроса для форматирования ячеек
  Call OptimizeMacro
  ' Вызов второй части макроса для удаления пустых строк и столбцов
  Call Удаление_пустых_строк_столбцов_обычная
End Sub
Sub OptimizeMacro()
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
  With ws.UsedRange
      .HorizontalAlignment = xlGeneral
      .VerticalAlignment = xlTop
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
  End With
  With Selection
      .HorizontalAlignment = xlGeneral
      .VerticalAlignment = xlTop
      .WrapText = True
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
  End With
Next ws
End Sub
Sub Удаление_пустых_строк_столбцов_обычная()
Dim wb As Workbook, ws As Worksheet, rng As Range, r As Long, c As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
  Set ws = ActiveSheet
  ' Удаление пустых строк
  For r = ws.UsedRange.Rows.Count To 1 Step -1
      If Application.WorksheetFunction.CountA(ws.Rows) = 0 Then
          If rng Is Nothing Then
              Set rng = ws.Rows
          Else
              Set rng = Union(rng, ws.Rows)
          End If
      End If
  Next r
  If Not rng Is Nothing Then rng.Delete
  Set rng = Nothing
  ' Удаление пустых столбцов
  For c = ws.UsedRange.Columns.Count To 1 Step -1
      If Application.WorksheetFunction.CountA(ws.Columns) = 0 Then
          If rng Is Nothing Then
              Set rng = ws.Columns
          Else
              Set rng = Union(rng, ws.Columns)
          End If
      End If
  Next c
  If Not rng Is Nothing Then rng.Delete
 
Next ws
End Sub

попросила чат GPT, чтобы он мне его скорретировал, он мне выдал это..но этот не работает вообще.
Sub ОбъединенныйМакрос()
   Dim ws As Worksheet
   Dim rng As Range
   Dim r As Long, c As Long

   For Each ws In ThisWorkbook.Worksheets
       ws.Activate
       Call OptimizeMacro
       Call Удаление_пустых_строк_столбцов_обычная
   Next ws
End Sub

Sub OptimizeMacro()
   With ActiveSheet.UsedRange
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlTop
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
End Sub

Sub Удаление_пустых_строк_столбцов_обычная()
   Dim rng As Range
   Dim r As Long, c As Long

   ' Удаление пустых строк
   For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
       If Application.WorksheetFunction.CountA(ActiveSheet.Rows®) = 0 Then
           If rng Is Nothing Then
               Set rng = ActiveSheet.Rows®
           Else
               Set rng = Union(rng, ActiveSheet.Rows®)
           End If
       End If
   Next r
   If Not rng Is Nothing Then rng.Delete

   Set rng = Nothing

   ' Удаление пустых столбцов
   For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
       If Application.WorksheetFunction.CountA(ActiveSheet.Columns©) = 0 Then
           If rng Is Nothing Then
               Set rng = ActiveSheet.Columns©
           Else
               Set rng = Union(rng, ActiveSheet.Columns©)
           End If
       End If
   Next c
   If Not rng Is Nothing Then rng.Delete
End Sub

Всем, доброе утро!! Прошу исправить код, он не работает со всеми листами книги, а только с активным.
Sub ОбъединенныйМакрос()
   ' Вызов первой части макроса для форматирования ячеек
   Call OptimizeMacro
   
   ' Вызов второй части макроса для удаления пустых строк и столбцов
   Call Удаление_пустых_строк_столбцов_обычная
End Sub

Sub OptimizeMacro()
   With ActiveSheet.UsedRange
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlTop
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
   With Selection
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlTop
       .WrapText = True
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
End Sub

Sub Удаление_пустых_строк_столбцов_обычная()
   Dim ws As Worksheet
   Dim rng As Range
   Dim r As Long, c As Long

   Set ws = ActiveSheet

   ' Удаление пустых строк
   For r = ws.UsedRange.Rows.Count To 1 Step -1
       If Application.WorksheetFunction.CountA(ws.Rows®) = 0 Then
           If rng Is Nothing Then
               Set rng = ws.Rows®
           Else
               Set rng = Union(rng, ws.Rows®)
           End If
       End If
   Next r
   If Not rng Is Nothing Then rng.Delete

   Set rng = Nothing

   ' Удаление пустых столбцов
   For c = ws.UsedRange.Columns.Count To 1 Step -1
       If Application.WorksheetFunction.CountA(ws.Columns©) = 0 Then
           If rng Is Nothing Then
               Set rng = ws.Columns©
           Else
               Set rng = Union(rng, ws.Columns©)
           End If
       End If
   Next c
   If Not rng Is Nothing Then rng.Delete

   MsgBox "Удаление пустых строк и столбцов завершено!"
End Sub

ВООБЩЕ круто! Очень быстро работает.Спасибо

Sub DeleteRowsBasedOnFilter()

   Dim selectedRange As Range
   Set selectedRange = Selection

   If selectedRange.Rows.Count < 2 Or selectedRange.Columns.Count < 1 Then
       MsgBox "Выделите диапазон для применения фильтров!", vbExclamation
       Exit Sub
   End If

   Dim i As Integer
   For i = 1 To selectedRange.Columns.Count
       selectedRange.AutoFilter Field:=i, Criteria1:="="
   Next i

   selectedRange.Rows("2:10000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
   ActiveSheet.ShowAllData

End Sub

Вот его сделать универсальным
Sub Удаление()

   Range("A1").Select
   Selection.AutoFilter
   ActiveSheet.UsedRange.AutoFilter Field:=6, Criteria1:="="
   ActiveSheet.UsedRange.AutoFilter Field:=8, Criteria1:="="
   Range("I1").Select
   ActiveSheet.UsedRange.AutoFilter Field:=10, Criteria1:="="
   Rows("2:7").Select
   On Error Resume Next
   Selection.SpecialCells(xlCellTypeVisible).Select
   Selection.Delete Shift:=xlUp
   On Error GoTo 0
   ActiveSheet.ShowAllData
End Sub

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

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

Прошу помочь настроить визуализацию план-факта

Доброе утро, прошу мне помочь. Как посчитать сколько месяцев на выполнение работ между 1 и 2 этапом ,между 2 и 3 этапом?

Всем добрый день, хочу поделиться своей проблемой. Если из Power Pivot стоить диаграммы, а затем их копировать, то возникает ошибка .А затем ексель просто завершает работу, при этом не сохраняет данные. У меня вопрос вот в чем, может только диаграммы, созданные из сводной таблицы копируются несколько раз? А из Power Pivot только должен быть оригинал, или у меня что-то настройками...подскажите мне как быть в этой ситуации?

Спасибо огромное!!!Получилось, выделила (пусто) и поставила пробел.

Добрый день, меня давно мучает вопрос, как убрать это слово (пусто). Есть сводная таблица, которая формируется из Модель данных.

Всем доброе утро, прошу мне помочь в написании макроса. У меня есть 2 выгрузки (новая и старая),которые надо сравнить.
1. Надо выделить диапазон из новой выгрузки и выделить диапазон из старой выгрузки.
2. результат сравнения перенести на соседний лист.

Доброе утро. Помогите, пожалуйста, решить такую задачу. Данные выгружаются из 1С, потом обрабатываются в PQ в конечном варианте представляются  на листе в Екселе в виде сводной таблицы и просто таблиц с данными. Моя задача, чтобы эти таблицы с данными и  с исходным форматированием перенеслись в Ворд (на новый документ). После того как они перенеслись в ворд, надо что таблицы встали по размеру содержимого или по размеру листа.

Ошибка 9 пишет

Добрый день, нет не работает макрос. Хотя я вроде выполнила условия Имя и название листа.