创建更快的循环

时间：2015-11-18 13:04:28

标签： excel-vba loops vba excel

我认为永远需要一个循环。它正在工作，但需要10分钟才能完成。任何人都可以指出一个方向，使其更快？我知道Pivot需要时间，但我希望这里有任何想法。循环通过大约40-80个细胞。

Sub GetStores()

Dim store As String

Application.ScreenUpdating = False

Sheets("Stores").Select
Range("A2").Select
Store= ActiveCell.Value


Do Until IsEmpty(ActiveCell)

Sheets("salescube").Select
ActiveSheet.PivotTables("Pivottabell1").PivotFields( _
    "[DimGeography].[Location].[Country]").VisibleItemsList = Array("")
ActiveSheet.PivotTables("Pivottabell1").PivotFields( _
    "[DimGeography].[Location].[Region]").VisibleItemsList = Array("")
ActiveSheet.PivotTables("Pivottabell1").PivotFields( _
    "[DimGeography].[Location].[SalesChannel]").VisibleItemsList = Array( _
    "[DimGeography].[Location].[SalesChannel].&[" & store & "]")

   Range("A:A,C:D").Select
Selection.Copy
 Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = Range("A2").Value
Range("B3").Select



Sheets("Stores").Select
ActiveCell.Offset(1, 0).Select
Store = ActiveCell.Value

Loop

Application.ScreenUpdating = True
End Sub

EDIT The Pivot, most cant be shown

忘记提及引用第一张纸的超链接（“商店”）

5 个答案:

答案 0 :(得分：2)

在更改数据透视表之前，请使用以下命令停止计算：

ActiveSheet.PivotTables("Pivottabell1").ManualUpdate = True

更改后，使用以下命令恢复计算：

ActiveSheet.PivotTables("Pivottabell1").ManualUpdate = False

答案 1 :(得分：2)

通用提示：使用对象并避免使用.Select

示例：而不是

Sheets("Stores").Select
Range("A2").Select
Store= ActiveCell.Value

使用

Store = Sheets("Stores").[A2]

（或Sheets("Stores").Range("A2")如果您不喜欢方括号表示法......是的，我们知道这是硬编码，您可能想要对如何避免这种情况做一些额外的想法。 ..）

而不是

Sheets("salescube").Select
ActiveSheet.PivotTables("Pivottabell1").PivotFields( _
    "[DimGeography].[Location].[Country]").VisibleItemsList = Array("")

使用

Dim PT As PivotTable
    ' ...
    Set PT = Sheets("salescube").PivotTables("Pivottabell1")
    ' ... Do While
        PT.PivotFields("...").VisibleItemsList = "..."
    ' ... Loop

复制/粘贴相同...并且您可以完全取消ScreenUpdating。

<强>详细信息： 

Sub GetStores()
Dim StoreIndex As Integer
Dim StoreRange As Range
Dim PT As PivotTable
Dim NewSheet As Worksheet

    ' prepare range and index for stores
    Set StoreRange = Sheets("Stores").[A2]
    StoreIndex = 1

    ' starting from here you can access all stores using StoreRange(StoreIndex, 1)

    ' prepare Pivot Table object
    Set PT = Sheets("SalesCube").PivotTables("PivotTabell1")


    Do While StoreRange(StoreIndex, 1) <> ""
        ' can't run this without having precise design of PT
        ' however at the end we have pivot filtered by current store

        ' PT.PivotFields( _
            "[DimGeography].[Location].[Country]").VisibleItemsList = Array("")
        ' PT.PivotFields( _
            "[DimGeography].[Location].[Region]").VisibleItemsList = Array("")
        ' PT .PivotFields( _
            "[DimGeography].[Location].[SalesChannel]").VisibleItemsList = Array( _
            "[DimGeography].[Location].[SalesChannel].&[" & StoreRange(StoreIndex, 1) & "]")

        ' create new sheet object and give it the name of current store
        Set NewSheet = Sheets.Add(, Sheets(Sheets.Count))
        NewSheet.Name = StoreRange(StoreIndex, 1)

        ' copy to new sheet PT in current filter mode by intersecting PT with "A:A,C:D"
        ' note: Application.Intersect(range1, range2) returns a range
        Application.Intersect(PT.RowRange.CurrentRegion, PT.Parent.Range("A:A,C:D")).Copy NewSheet.[A1]

        ' increment loop counter
        StoreIndex = StoreIndex + 1
    Loop

End Sub

答案 2 :(得分：0)

butikk = ActiveCell.Value需要store = ActiveCell.Value;否则你会一次又一次地重新计算相同的值 "[DimGeography].[Location].[SalesChannel].&[" & store & "]") - 我认为应该没有“＆amp;”在最后一个点之后。
真正需要时间的是复制整个列A:A和C:D。您应该只找到最后一次使用的行和从第1行到最后一行的副本。您可以使用它来获取最后一行：

Public Function lastrow(Optional aSheet As Worksheet) As Long
    If aSheet Is Nothing Then Set aSheet = ActiveSheet
    lastrow = aSheet.Cells.Find("*", SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
End Function

然后使用range(cells(1,1),cells(lastrow(),1)和range(cells(1,3),cells(lastrow(),4)代替 当您正在处理多个工作表时，使用适当的工作表名称限定范围和cells以避免错误。

答案 3 :(得分：0)

此过程包括原始代码中缺少的一些验证：

  • 如果透视表过滤器
    • 失败，则突出显示工作表Stores中的商店值
  • 删除工作表以复制所选数据（如果已存在）
  • 避免使用剪贴板 - 可选（它还包括使用剪贴板的选项，因为我们需要复制原始单元格的格式）
  • 通过禁用某些应用程序属性来提高性能
  • 在继续使用过滤器之前刷新数据透视表
  • 使用pivottable属性确定要复制的范围

建议阅读这些页面，以便更深入地了解程序中使用的资源

Variables & Constants，Application Object (Excel)，Excel Objects

With Statement，GoSub...Return Statement，Range Object (Excel)

PivotTable Members (Excel)，Range.PasteSpecial Method (Excel)

如果您对该程序有任何疑问，请与我们联系。

Option Explicit

Sub GetStores_Published()
Dim Ptb As PivotTable
Dim Wsh As Worksheet
Dim rStore As Range, sStore As String
Dim rSrc As Range
Dim blErr As Boolean
Dim sShtName As String
Dim lPtbRowLst As Long

    Rem Application Settings
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With ThisWorkbook

        Rem Set Objects
        Set rStore = .Sheets("Stores").Range("A2")
        sStore = rStore.Value2
        'Assuming there is only one PivotTable in Sheet salescube
        Set Ptb = .Sheets("salescube").PivotTables(1)
        'Otherwise use line below
        'Set Ptb = .Sheets("salescube").PivotTables("Pivottabell1")

        Rem PivotTable Refresh and Set to Manual
        Ptb.RefreshTable

        Do
            With Ptb

                Rem Filter Pivot Table
                .PivotFields("[DimGeography].[Location].[Country]").VisibleItemsList = Array("")
                .PivotFields("[DimGeography].[Location].[Region]").VisibleItemsList = Array("")
                blErr = False
                On Error Resume Next
                .PivotFields("[DimGeography].[Location].[SalesChannel]").VisibleItemsList = _
                    Array("[DimGeography].[Location].[SalesChannel].&[" & sStore & "]")
                Rem Validates Filter on Store
                If Err.Number <> 0 Then blErr = True
                On Error GoTo 0
                If blErr Then GoTo NEXT_Store

                Rem Set PivotTable Last Row
                lPtbRowLst = -1 + .TableRange1.Row + .TableRange1.Rows.Count

                Rem Set New Sheet Name & Range to be Copied
                sShtName = .Parent.Range("A2").Value2
                Set rSrc = .Parent.Range("A1:A" & lPtbRowLst & ",C1:D" & lPtbRowLst)

            End With

            Rem Add Worksheet - Store
            On Error Resume Next
            .Sheets(sShtName).Delete
            On Error GoTo 0
            Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))


            Rem Copy Values from Source Range
            With Wsh
                .Name = sShtName

                Rem Use these lines to copy only values - does not use clipboard
                '.Range("A1:A" & lPtbRowLst).Value = rSrc.Areas(1).Value2
                '.Range("B1:C" & lPtbRowLst).Value = rSrc.Areas(2).Value2

                Rem use these lines to copy\paste values & formats as in the original sheet - uses of clipboard
                rSrc.Copy
                .Cells(1).PasteSpecial Paste:=xlPasteValues
                .Cells(1).PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False     'Clears the clipboard

                .Cells(3, 2).Activate
            End With

            Rem Copy Values from Source Range
            With Wsh
                .Name = sShtName
                .Range("A1:A" & lPtbRowLst).Value = rSrc.Areas(1).Value2
                .Range("B1:C" & lPtbRowLst).Value = rSrc.Areas(2).Value2
                .Cells(3, 2).Activate
            End With

NEXT_Store:
            Rem Reset Store Range
            'Highlights Cell If PT Filter By Scope Failed
            If blErr Then rStore.Interior.Color = RGB(255, 255, 0)
            Set rStore = rStore.Offset(1, 0)
            sStore = rStore.Value2

        Loop Until sStore = Empty

    End With

    Rem Application Settings
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

答案 4 :(得分：-1)

我只想展示我最终完成的代码。再次感谢@EEM 

Sub GetStores_Published()
Dim Ptb As PivotTable
Dim Wsh As Worksheet
Dim rStore As Range, sStore As String
Dim rSrc As Range
Dim blErr As Boolean
Dim sShtName As String
Dim lPtbRowLst As Long

Rem Application Settings
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

With ThisWorkbook

    Rem Set Objects
    Set rStore = .Sheets("Stores").Range("C3")
    sStore = rStore.Value2
    'Assuming there is only one PivotTable in Sheet salescube
    Set Ptb = .Sheets("Salescube").PivotTables(1)
    'Otherwise use line below
    'Set Ptb = .Sheets("salescube").PivotTables("Pivottabell1")

    Rem PivotTable Refresh and Set to Manual
    Ptb.RefreshTable

    Do
        With Ptb

            Rem Filter Pivot Table
            .PivotFields("[DimGeography].[Location].[Country]").VisibleItemsList = Array("")
            .PivotFields("[DimGeography].[Location].[Region]").VisibleItemsList = Array("")
            blErr = False
            On Error Resume Next 'change [SalesChannel] med [Region]
            .PivotFields("[DimGeography].[Location].[Region]").VisibleItemsList = _
                Array("[DimGeography].[Location].[Region].&[" & sStore & "]")
            Rem Validates Filter on Store
            If Err.Number <> 0 Then blErr = True
            On Error GoTo 0
            If blErr Then GoTo NEXT_Store

            Rem Set PivotTable Last Row
            lPtbRowLst = -1 + .TableRange1.Row + .TableRange1.Rows.Count

            Rem Set New Sheet Name & Range to be Copied
            sShtName = .Parent.Range("B4").Value2
            Set rSrc = .Parent.Range("A1:A" & lPtbRowLst & ",C1:D" & lPtbRowLst)

        End With

        Rem Add Worksheet - Store
        On Error Resume Next
        .Sheets(sShtName).Delete
        On Error GoTo 0
        Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))


        Rem Copy Values from Source Range
        With Wsh
            .Name = sShtName

            Rem Use these lines to copy only values - does not use clipboard
            '.Range("A1:A" & lPtbRowLst).Value = rSrc.Areas(1).Value2
            '.Range("B1:C" & lPtbRowLst).Value = rSrc.Areas(2).Value2

            Rem use these lines to copy\paste values & formats as in the original sheet - uses of clipboard. Added one more that gets all formats
            rSrc.Copy
            .Cells(1).PasteSpecial
            Columns().AutoFit
            '.Cells(1).PasteSpecial Paste:=xlPasteValues
            '.Cells(1).PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False     'Clears the clipboard

            .Cells(3, 2).Activate
        End With

        Rem Copy Values from Source Range
        With Wsh
            .Name = sShtName
            .Range("A1:A" & lPtbRowLst).Value = rSrc.Areas(1).Value2
            .Range("B1:C" & lPtbRowLst).Value = rSrc.Areas(2).Value2
            .Cells(3, 2).Activate
        End With

NEXT_Store:
        Rem Reset Store Range
        'Highlights Cell If PT Filter By Scope Failed
        If blErr Then rStore.Interior.Color = RGB(255, 255, 0)
        Set rStore = rStore.Offset(1, 0)
        sStore = rStore.Value2

    Loop Until sStore = Empty

End With

Rem Application Settings
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
相关问题
最新问题