每个VBA多次循环遍历工作簿中的工作表

问题描述

我在excel工作簿中有一个VBA脚本，该脚本循环遍历大量工作表（大约100张）以将数据合并到一张工作表中。这也是从PDF文件导出的数据。我试图清除所有不可打印的字符和格式，但是不确定是否错过了一些。

它使用单个For Each ws In Workbook循环，但是在执行脚本时，脚本在工作簿中循环看似随机的次数，并在看似随机的工作表处停止。这会引起问题，因为有时执行摘要时，摘要变为10K行而不是1K。

有人知道为什么会这样吗？

由于数据是从PDF导入的，因此无法以有用的方式进行格式化。我还有其他脚本可以将我带到此处进行合并和使用超级查询。每个工作表的布局为：

|------|---------------|---------|--------------|----------|
| Buy  |  Description  |  Symbol |   Price ($)  |  null    |
| null |  Lrg Co       |  VOO    |   $242.55    | 1/2/2018 |
| cont....

还有VBA代码（不是最漂亮的，但是几乎完成了工作...）：

Sub summarize()
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim i As Integer
    Dim stcol As Integer
    Dim endcol As Integer
    Dim strow As Integer
    Dim endrow As Integer
    Dim symrng As Range
    Dim totrow As Integer
    Dim j As Integer
    Dim itm As Range
    Dim lr As Long
    
    j = 1
    
    For Each ws In Worksheets
        stcol = 1       
        Set symrng = ws.Cells.Find("Symbol",LookAt:=xlPart,MatchCase:=False)      
        strow = symrng.Row      
        endcol = symrng.Offset(1,0).End(xlToRight).Column     
        endrow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
        Set symrng = nothing
        totrow = endrow - strow
        
        For i = 0 To totrow
            Worksheets("Summary").Range(Worksheets("Summary").Cells(j + 1,1),Worksheets("Summary").Cells(j + 1,endcol)).Value = itm.Value
            j = j + 1
        Next i
    Next ws
    
    Application.ScreenUpdating = True

End Sub

解决方法

谢谢@FoxFireBurnsandBurns的想法，我只用了几张纸跑了脚本。我没有测试Summary，因此它一直对导入的数据进行迭代，直到我猜excel触发了内存断路器。添加此行将其修复：

If ws.Name = "Summmary" Then GoTo Nextws:

完整的代码是：

Sub summarize()
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim i As Integer
    Dim stcol As Integer
    Dim endcol As Integer
    Dim strow As Integer
    Dim endrow As Integer
    Dim symrng As Range
    Dim totrow As Integer
    Dim j As Integer
    Dim itm As Range
    Dim lr As Long
    
    j = 1
    
    For Each ws In Worksheets
        ' Exclude Summary Sheet
        If ws.Name = "Summmary" Then GoTo Nextws:

        stcol = 1       
        Set symrng = ws.Cells.Find("Symbol",LookAt:=xlPart,MatchCase:=False)      
        strow = symrng.Row      
        endcol = symrng.Offset(1,0).End(xlToRight).Column     
        endrow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
        Set symrng = Nothing
        totrow = endrow - strow
        
        For i = 0 To totrow
            Worksheets("Summary").Range(Worksheets("Summary").Cells(j + 1,1),Worksheets("Summary").Cells(j + 1,endcol)).Value = itm.Value
            j = j + 1
        Next i
Nextws:
    Next ws
    
    Application.ScreenUpdating = True

End Sub