数据大了就会内存溢出，如何解决？

as512468

在一列数据中，如果两个相同的数之间相距小于等于3个单元格则视为“连续” ，反之，则视为不连续，我想请教的是，如果一列数据中“连续”出现大于等于9次的数， 则需要把“连续”的范围内所有的数找到并提取到“”sheet2结果“工作表， 但是数据非常庞大，经常出现“内存溢出”，不知代码是否有错？请大神帮忙看一下。 代码如下:

Sub sdf()

    T = Sheet3.Range("a1")

    Arr = Sheet1.Range("a1").CurrentRegion

    a = UBound(Arr) + 1
    b = UBound(Arr, 2)

    Sheet2.UsedRange.ClearContents

    Cells(a, 1).Resize(4, b).Value = T + 1

    Erase Arr

    Arr = Sheet1.Range("a1").CurrentRegion

    Cells(a, 1).Resize(4, b).ClearContents

    ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))

    For c = 1 To UBound(Arr, 2)
        Cnt = 0
    For r = 1 To UBound(Arr) - 4

        If Arr(r, c) = T Then

            Cnt = Cnt + 1

            If Cnt = 1 Then SR = r

            If Arr(r + 1, c) = T Then


            ElseIf Arr(r + 2, c) = T Then

            ElseIf Arr(r + 3, c) = T Then

            ElseIf Arr(r + 4, c) = T Then

            Else

                ER = r

                If Cnt >= 9 And ER - SR < 15 Then

                    For i = 1 To ER - SR + 1

                        Brr(i, c) = Arr(SR + i - 1, c)

                    Next

                    GoTo line

                End If

                Cnt = 0


            End If

        End If


    Next
line:
    Next

    Sheet2.Range("a1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr

    Erase Arr
    Erase Brr
End Sub

3190496160

把变量   c 和 r 都定义为 long类型试试看看吧

Dim c As Long
Dim r As Long

microyip

以第一列为例，其余的扩展就自己参考修改

1. Sub 查找数据()
   
2.     Dim vData As Variant, nRow As Double, nCol As Long
   
3.     Dim oDic As Object, nFillCol As Long
   
4.     Dim vVal As Variant
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     With Sheet2
   
8.         .Cells.ClearContents
   
9.         Set oDic = CreateObject("Scripting.Dictionary")
   
10.         vData = Sheet1.[A1].CurrentRegion.Value
    
11.         For nRow = 1 To UBound(vData)
    
12.             vVal = vData(nRow, 1)
    
13.             If Not oDic.Exists(vVal) Then
    
14.                 Set oDic(vVal) = CreateObject("Scripting.Dictionary")
    
15.                 oDic(vVal)("第一行") = nRow
    
16.                 oDic(vVal)("上一行") = nRow
    
17.             End If
    
18.             If nRow - oDic(vVal)("上一行") <= 3 Then
    
19.                 oDic(vVal)("上一行") = nRow
    
20.                 oDic(vVal)("次数") = oDic(vVal)("次数") + 1
    
21.                 If oDic(vVal)("次数") >= 9 Then
    
22.                     nFillCol = nFillCol + 1
    
23.                     .Cells(1, nFillCol).Resize(nRow - oDic(vVal)("第一行") + 1) = Sheet1.Cells(oDic(vVal)("第一行"), 1).Resize(nRow - oDic(vVal)("第一行") + 1).Value
    
24.                 End If
    
25.             Else
    
26.                 oDic.Remove vVal
    
27.                 nRow = nRow - 1
    
28.             End If
    
29.         Next
    
30.     End With
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码

microyip

附上附件以供参考