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

我不确定，但仍然可以使用以下代码刷新具有新范围的现有数据透视表：

   '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

Answer 2

将此代码粘贴到模块中，并修改<<<<自定义此>>>>部分

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

将范围从工作表复制到可视化数据的主工作表

2 个答案: