Копирование диапазона из рабочих таблиц в главную рабочую таблицу, где данные визуализируются

Question

Я пытаюсь скопировать определенный диапазон данных из всех листов, которые не имеют названия «Pivot_Time» или «Pivot_Expenses» или «Pull & Copy Data», и вставить их в текущий лист.

Пока мой код делает то, что я хочу, но, поскольку я хочу визуализировать данные с помощью сводной диаграммы, вставленные данные должны быть отформатированы в виде таблицы.К сожалению, мой код этого не делает.Любые идеи о том, как я могу это сделать?

Заранее спасибо!

Это код, который я пробовал:

Option Explicit

Sub CopyRangeToPivotTable_Pivot_Time()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Pivot_Time" And ws.Name <> "Pivot_Expenses" _
        And ws.Name <> "Pull & Copy Data" Then
            ws.Range("A14:L26").Copy
            Sheets("Pivot_Time").Cells(Rows.Count, "K").End(xlUp).Offset (1)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

Вставьте этот код в модуль и адаптируйте <<<< настроить этот >>>> раздел

Sub CopyRangeToPivotTable_Pivot_Time()

    ' Declare objects variables
    Dim sourceSheet As Worksheet
    Dim destinationTable As ListObject

    ' Declare other variables
    Dim destinationSheetName As String
    Dim destinationTableName As String
    Dim sourceRangeAddress As String
    Dim specialSheetsList() As Variant

    ' <<<< Customize this >>>>
    destinationSheetName = "Pivot_Time"
    destinationTableName = "Table1"
    sourceRangeAddress = "A14:L26"
    specialSheetsList = Array("Pivot_Time", "Pivot_Expenses", "Pull & Copy Data")

    ' Initialize destination table
    Set destinationTable = ThisWorkbook.Worksheets(destinationSheetName).ListObjects(destinationTableName)

    ' When using screenupdating you better add an error handler, cause you might end up with the screen not updating, restarting excel if the procedure fails, and possibly loosing data
    Application.ScreenUpdating = False

    For Each sourceSheet In ThisWorkbook.Worksheets ' if the macro is going to run in other workbooks, return to activeworkbook

        If IsInArray(sourceSheet.Name, specialSheetsList) = False Then


            ' Copy the range - no clipboard
            destinationTable.DataBodyRange.Cells(destinationTable.DataBodyRange.Rows.Count, 1).Offset(1, 0).Resize(Range(sourceRangeAddress).Rows.Count, Range(sourceRangeAddress).Columns.Count).Value = sourceSheet.Range(sourceRangeAddress).Value

            ' Resize the table to include the new data
            destinationTable.Resize destinationTable.Range.CurrentRegion


        End If

    Next sourceSheet

    Application.ScreenUpdating = True

End Sub

' Credits: https://wellsr.com/vba/2016/excel/check-if-value-is-in-array-vba/
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
'DEVELOPER: Ryan Wells (wellsr.com)
'DESCRIPTION: Function to check if a value is in an array of values
'INPUT: Pass the function a value to search for and an array of values of any data type.
'OUTPUT: True if is in array, false otherwise
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

Answer 2

Я не уверен, но все же вы можете обновить существующую сводную таблицу новым диапазоном, используя следующий код:

   'Refresh Pivot table
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    NewRange = "Pivot_Time!A1:AL" & LastRow 'Set Range as per your requirement
    Sheets("Pivot Sheet").Select 'Set the sheet name where your pivot table is saved
    Sheets("Pivot Sheet").PivotTables("pivot table name").ChangePivotCache ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)
    ThisWorkbook.Worksheets("Pivot Sheet").PivotTables("pivot table name").RefreshTable