Страницы: 1
RSS
Преобразовать таблицу с данными в умную, Преобразовать таблицу на листе с помощью VBA и присвоить ей имя
 
Доброго времени суток. Помогите пожалуйста, как с помощью макроса преобразовать простую таблицу с данными в умную. Нужно для дальнейшей обработки в PQ.
Пример таблицы во вложении, в очень сокращённом виде. Строк обычно 30К+. Таблица подтягивается в файл тоже макросом, но вставляется как обычная. Макрос при обновлении этой таблицы зачищает лист от всех данных и форматов...
Помогите пожалуйста с нужными строками кода, которые можно дописать в имеющийся макрос, чтобы на выходе получалась умная таблица с именем.
Заранее спасибо.
 
Цитата
Вадим Кокуев написал:
Помогите пожалуйста с нужными строками кода, которые можно дописать в имеющийся макрос
Но макрос не покажу!  8)
 
RAN, Легко :) Лепил как мог, но на этом месте встрял...
Может поможете упростить если намудрил сильно, собирал всё по кусочкам, что-то здесь, что-то там :)
Код
Sub ShowFileDialog()
    Dim oFD As FileDialog
    Dim x, lf As Long
    Dim pivotF As PivotField
        Application.ScreenUpdating = False
        Sheets("DATA").Cells.Clear
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD
        .AllowMultiSelect = False
        .Title = "Выбрать файл отчёта"
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1
        .InitialFileName = "C:\"
        .InitialView = msoFileDialogViewDetails
        If oFD.Show = 0 Then Exit Sub
        For lf = 1 To .SelectedItems.Count
        x = .SelectedItems(lf)
        Workbooks.Open x
        Next
    End With
    Sheets("Выполнение Плана по Клиентам").Activate
    For Each pivotF In ActiveSheet.PivotTables("Сводная таблица3").RowFields
        If pivotF.Position < ActiveSheet.PivotTables("Сводная таблица3").RowFields.Count Then
            pivotF.DrilledDown = True
        End If
    Next pivotF
    ActiveSheet.PivotTables("Сводная таблица3").TableRange1.Copy
    ThisWorkbook.Sheets("DATA").Range("A1").PasteSpecial Paste:=xlPasteValues
    ThisWorkbook.Sheets("DATA").Range("A1").PasteSpecial Paste:=xlPasteFormats
    ThisWorkbook.Sheets("DATA").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False
    ActiveWindow.Close False
    ThisWorkbook.RefreshAll
    Application.ScreenUpdating = True
End Sub
Изменено: Вадим Кокуев - 12.05.2022 20:23:39
 
Last = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Лист1").ListObjects.Add(xlSrcRange, Range("A1:P" & Last), , xlYes).Name = "Таблица1"
 
Ham13, Спасибо огромное!
Изменено: Вадим Кокуев - 12.05.2022 22:13:15
Страницы: 1
Наверх