Fatal编程技术网
  • excel/
  • Excel 创建更快的循环

Excel 创建更快的循环

excel loops vba

Excel 创建更快的循环,excel,loops,vba,Excel,Loops,Vba,有一个循环，我想需要永远。它正在工作，但需要10分钟才能完成。有谁能给我指出一个能让这一切更快的方向吗？我知道支点需要时间，但我希望这里的任何人都有想法。这个环穿过大约40-80个细胞 Sub GetStores() Dim store As String Application.ScreenUpdating = False Sheets("Stores").Select Range("A2").Select Store= ActiveCell.Value Do Until IsEmp

有一个循环，我想需要永远。它正在工作，但需要10分钟才能完成。有谁能给我指出一个能让这一切更快的方向吗？我知道支点需要时间，但我希望这里的任何人都有想法。这个环穿过大约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
编辑

忘记提及指向第一张工作表（“存储”）的超链接在更改透视表之前，请使用以下命令停止计算：

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

ActiveSheet.PivotTables("Pivottabell1").ManualUpdate = False
更改后，使用以下命令恢复计算：

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

ActiveSheet.PivotTables("Pivottabell1").ManualUpdate = False
一般提示：使用对象并避免
。选择

例：代替


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



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


使用

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

而不是


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



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


使用

复制/粘贴也一样。。。您可以一起消除
屏幕更新



详细信息：


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



Sub-GetStores（）
将索引设置为整数
暗淡的存储范围作为范围
数据透视表
将新闻纸变暗为工作表
'为存储准备范围和索引
Set StoreRange=图纸（“存储”）[A2]
StoreIndex=1
'从这里开始，您可以使用StoreRange（StoreIndex，1）访问所有存储
'准备透视表对象
设置PT=工作表（“SalesCube”）。数据透视表（“数据透视表1”）
当StoreRange（StoreIndex，1）”时执行此操作
“如果没有精确的PT设计，就无法运行此功能
“然而，在最后，我们通过当前商店筛选了pivot
'部分数据透视字段（_
“[DimGeography].[Location].[Country]”。VisibleItemsList=Array（“”）
'部分数据透视字段（_
“[DimGeography].[Location].[Region]”。VisibleItemsList=Array（“”）
'部分数据透视字段（_
“[DimGeography].[Location].[SalesChannel]”。VisibleItemsList=Array（_
“[DimGeography].[Location].[SalesChannel].&[”&StoreRange（StoreIndex，1）&“]）”
'创建新的图纸对象并为其指定当前存储的名称
设置新闻纸=工作表。添加（，工作表（工作表数））
NewSheet.Name=StoreRange（StoreIndex，1）
'通过将PT与“A:A，C:D”相交，在当前筛选模式下复制到新的图纸PT'
'注意：Application.Intersect（range1，range2）返回一个范围
Application.Intersect（PT.RowRange.CurrentRegion，PT.Parent.Range（“A:A，C:D”））。复制新闻纸。[A1]
'增量循环计数器
StoreIndex=StoreIndex+1
环
端接头

butikk=ActiveCell.Value
需要是
store=ActiveCell.Value
；否则，您将一次又一次地重新计算相同的值。


“[DimGeography].[Location].[SalesChannel].&[”&store&“]）
-我认为最后一个点后面不应该有“&”。

真正需要时间的是复制整个列
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


然后使用
范围（单元格（1,1）、单元格（lastrow（），1）
和
范围（单元格（1,3）、单元格（lastrow（），4）
。


在处理多个工作表时，请使用适当的工作表名称限定范围和单元格，以避免出现错误。
此过程包括原始代码中缺少的一些验证：


    

  • 如果透视表筛选失败，则突出显示工作表中的存储值
    Stores
    • 

  • 删除工作表以复制所选数据（如果已存在）
    • 

  • 避免使用剪贴板-可选（它还包括使用剪贴板的选项，因为我们需要复制原始单元格的格式）
    • 

  • 通过禁用某些应用程序属性来提高性能
    • 

  • 在继续使用筛选器之前刷新透视表
    • 

  • 使用数据透视表属性确定要复制的范围
    • 


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

,

,

,

让我知道你对这个过程有什么疑问


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



选项显式
Sub-GetStores_Published（）
将Ptb设置为数据透视表
将Wsh设置为工作表
Dim R存储为范围，S存储为字符串
变暗rSrc As范围
Dim blErr为布尔型
将sShtName设置为字符串
变暗lPtbRowLst与长
Rem应用程序设置
Application.Calculation=xlCalculationManual
Application.EnableEvents=False
Application.DisplayAlerts=False
Application.ScreenUpdating=False
使用此工作簿
Rem集合对象
设置rStore=.Sheets（“存储”）.Range（“A2”）
sStore=rStore.Value2
'假设Sheet salescube中只有一个数据透视表
设置Ptb=.Sheets（“salescube”）。数据透视表（1）
'否则使用下面的行
'设置Ptb=.Sheets（“salescube”）.PivotTables（“Pivottabell1”）
Rem数据透视表刷新并设置为手动
刷新表
做
使用Ptb
Rem过滤器透视表
.PivotFields（“[DimGeography].[Location].[Country]”）。VisibleItemsList=Array（“”）
.PivotFields（“[DimGeography].[Location].[Region]”）。VisibleItemsList=Array（“”）
blErr=False
出错时继续下一步
.PivotFields（“[DimGeography].[Location].[SalesChannel]”）。VisibleItemsList=_
数组（“[DimGeography].[Location].[SalesChannel].&[”&sStore&“]））
Rem验证存储上的筛选器
如果错误号为0，则blErr=True
错误转到0
如果是blErr，则转到下一个商店
Rem设置数据透视表的最后一行
lPtbRowLst=-1+.TableRange1.Row+.TableRange1.Rows.Count
Rem设置要复制的新图纸名称和范围
sShtName=.Parent.Range（“A2”）.Value2
设置rSrc=.Parent.Range（“A1:A”和lPtbRowLst&“，C1:D”和lPtbRowLst）
以