VBA运行时错误7内存不足

Question

这可能在这里某处，我想念它，只是让我知道。

运行宏后，我得到运行时错误7内存不足。 调试之后，就在这行：

cell.Offset(0, 6).Value = Sheets("MakeRing_Maths").Range("N1").Value

该代码旨在按照经度和纬度列出机场，创建将被解释为圆形的线段，然后转换为.KML（由Google Earth Pro读取）。

这是其余的代码-我该如何清理类似的东西以避免内存泄漏？

感谢所有答案，或指向其他帖子的指针。 我知道很多，因此也欢迎提出一般建议！ 谢谢！

Sub PLANEMAN_Coords()

Dim Latitude As Double
Dim Longitude As Double
Dim Bearing As Integer
Dim LeftRight As Integer
Dim RangeKM As Double
Dim MinRange As Double

For Each cell In [RangeRings_ENTER!B9:B5001]

    If cell.Value = "" Then
        GoTo EXITLOOP
    Else
    End If

    Latitude = cell.Offset(0, 1)
    Longitude = cell.Value

    'set default values:

    'line width
    If cell.Offset(0, 2).Text = "" Then
        cell.Offset(0, 2).Value = 2
        'default line width = 2
    Else
    End If

    'radius
    If cell.Offset(0, 5).Text = "" Then
       cell.Offset(0, 5).Value = 8.04672
        'default radius = 8.04672 km = 5 miles
    Else
    End If
    RangeKM = cell.Offset(0, 5)

    'line color
    If cell.Offset(0, 3).Text = "" Then
        cell.Offset(0, 3).Value = "ff0000ff"
        'default line color is Red
    Else
    End If

    'common code
    Sheets("MakeRing_Maths").Range("D3").Value = Longitude
    Sheets("MakeRing_Maths").Range("E3").Value = Latitude
    Sheets("MakeRing_Maths").Range("D1").Value = RangeKM

    'code that differs depending on range-ring type
    If cell.Offset(0, 7).Text = "Circle" Then
        Sheets("MakeRing_Maths").Range("J1").Value = 0 'Bearing
        Sheets("MakeRing_Maths").Range("J2").Value = 180 'width - ie 2 x 180 = 360 = complete circle
        Calculate
        cell.Offset(0, 6).Select 'just so that the user can 'see' that the macro is still running and not crashed
        cell.Offset(0, 6).Value = Sheets("MakeRing_Maths").Range("N1").Value
    Else
        'else wedge of some sort

        Bearing = cell.Offset(0, 8)
        LeftRight = cell.Offset(0, 9)
        MinRange = cell.Offset(0, 10)

        Sheets("MakeRing_Maths").Range("J1").Value = Bearing
        Sheets("MakeRing_Maths").Range("J2").Value = LeftRight

        If cell.Offset(0, 7).Text = "Wedge" Then
            Calculate
            cell.Offset(0, 6).Select 'just so that the user can 'see' that the macro is still running and not crashed
            cell.Offset(0, 6).Value = Sheets("MakeRing_Maths").Range("N2").Value
        Else 'else a wedge with minimum range component 'Wedge2
            If cell.Offset(0, 7).Text = "Wedge2" Then
                Sheets("MakeRing_Maths").Range("F1").Value = MinRange
                Calculate
                cell.Offset(0, 6).Select 'just so that the user can 'see' that the macro is still running and not crashed
                cell.Offset(0, 6).Value = Sheets("MakeRing_Maths").Range("N3").Value
            Else
                If cell.Offset(0, 7).Text = "Arrow" Then
                    Sheets("MakeRing_Maths").Range("F1").Value = RangeKM * 0.95
                    Calculate
                    cell.Offset(0, 6).Select 'just so that the user can 'see' that the macro is still running and not crashed
                    cell.Offset(0, 6).Value = Sheets("MakeRing_Maths").Range("N4").Value
                Else
                    'HERE
                End If
            End If
        End If
    End If
Next

EXITLOOP:

Call PLANEMAN_RangeRings_KML 'make KML file

End Sub



Sub PLANEMAN_RangeRings_KML()
' Original inspiration code by simon_a
' Planeman 2009

    'get user to specify save location and name
    Dim ThisAddress As String
    ChDir ThisWorkbook.Path
    ThisAddress = Application.GetSaveAsFilename(FileFilter:="KML Files (*.kml),*.kml", Title:="Save Location & Name")

    ' file details
    filePath = ThisAddress
    docName = "PLANEMAN.KML"
    FolderName = "Folder"

    Open filePath For Output As #1

    'Write header to file
    outputText = "<?xml version=""1.0"" encoding=""UTF-8""?> <kml xmlns=""http://www.opengis.net/kml/2.2"" xmlns:gx=""http://www.google.com/kml/ext/2.2"" xmlns:kml=""http://www.opengis.net/kml/2.2"" xmlns:atom=""http://www.w3.org/2005/Atom""> <Document><name>" & docName & "</name>    <Folder>    <name>" & FolderName & "</name>  <open>1</open>"
    Print #1, outputText

    'loop
    For Each cell In [RangeRings_ENTER!B9:B5001]

        If cell.Value = "" Then
           Exit For
        End If

        StrPart1 = "<Style id=""sn_ylw-pushpin""><IconStyle><color>" & cell.Offset(0, 3) & "</color></IconStyle><LineStyle><width>" & cell.Offset(0, 2) & "</width><color>" & cell.Offset(0, 3) & "</color></LineStyle><PolyStyle><color>" & cell.Offset(0, 3) & "</color></PolyStyle></Style>"
        StrPart2 = "<Placemark><name>" & cell.Offset(0, -1) & "</name>  <styleUrl>#sn_ylw-pushpin</styleUrl>    <LineString>    "
        StrPart3 = "<coordinates>" & cell.Offset(0, 6) & ",0 </coordinates> </LineString></Placemark>"

        'Create a placemark
        outputText = StrPart1 & StrPart2 & StrPart3
        Print #1, outputText

    Next

   'Write footer to file
    outputText = "</Folder></Document></kml>"
    Print #1, outputText

    Close #1

    MsgBox "Macro Complete"

'
End Sub

Sub PLANEMAN_Placemarks_KML()
' Original inspiration code by simon_a
' Planeman 2009

    'get user to specify save location and name
    Dim ThisAddress As String
    ChDir ThisWorkbook.Path
    ThisAddress = Application.GetSaveAsFilename(FileFilter:="KML Files (*.kml),*.kml", Title:="Save Location & Name")

    ' file details
    filePath = ThisAddress
    docName = "PLANEMAN.KML"
    FolderName = "PlacemarkFolder"

    Open filePath For Output As #1

    'Write header to file
    outputText = "<?xml version=""1.0"" encoding=""UTF-8""?><kml xmlns=""http://www.opengis.net/kml/2.2""> <Document><name>" & docName & "</name>    <Folder>    <name>" & FolderName & "</name>  <open>1</open>"
    Print #1, outputText

    'loop
    For Each cell In [Placemarks_ENTER!B9:B5001]

        If cell.Value = "" Then
           Exit For
        End If

        StrPart1 = ""
        StrPart2 = " <Placemark> <name> " & cell.Offset(0, -1) & " </name> "
        StrPart3 = cell.Offset(0, 6) & "<Point><coordinates> " & cell.Offset(0, 0) & "," & cell.Offset(0, 1) & ",0</coordinates> </Point> </Placemark>"

        'Create a placemark
        outputText = StrPart1 & StrPart2 & StrPart3
        Print #1, outputText

    Next

   'Write footer to file
    outputText = "</Folder></Document></kml>"
    Print #1, outputText

    Close #1

    MsgBox "Macro Complete"

'
End Sub

Answer 1

非常感谢您的回答，我找到了解决方案！

事实证明，一个简单的解决方法是截断一些非常大的数字（15个以上的十进制数字），现在它像一个符咒一样通过。

感谢您的时间！

UPATE：

始终要在代码中添加Option Explicit并明确声明变量。 您可以按照以下步骤进行配置，因此编辑器会自动添加此行。 通过这种方式，您知道并能够管理变量，根据其内存分配处理数据类型。

一种。 在Visual Basic编辑器中，单击“工具”，然后单击“选项”。

湾 选中需要变量声明。

对于这样的情况，对于VBA编译器来说，通过更具表现力的错误消息（例如，值太大）而不是普通的旧通用内存不足，将是非常不错的。 无论如何，以下链接说明了导致此错误的可能原因。

需要的内存多于可用内存，或者遇到了64K段边界。 该错误具有以下原因和解决方案：

您打开了太多的应用程序，文档或源文件。 关闭所有不必要的应用程序，文档或打开的源文件。

您的模块或过程太大。

将大型模块或过程分成较小的模块。 这不会节省内存，但是可以防止达到64K的段边界。

您正在以标准模式运行Microsoft Windows。 在增强模式下重新启动Microsoft Windows。

您正在以增强模式运行Microsoft Windows，但是虚拟内存已用完。 通过释放一些磁盘空间来增加虚拟内存，或者至少确保有一些可用空间。

您正在运行终止驻留程序。 消除终止并停留的计划。

您已加载许多设备驱动程序。 消除不必要的设备驱动程序。

您的公共变量空间已用完

减少公共变量的数量。

（1） Excel规格和限制。

（2） Microsoft Excel中的数值精度。

VBA内的准确性尽管默认情况下Excel在名义上可以使用8字节数字，但VBA具有多种数据类型。 Double数据类型是8个字节，Integer数据类型是2个字节，并且可以使用VBA转换函数CDec.16将通用16字节Variant数据类型转换为12字节Decimal数据类型。 在VBA计算中选​​择变量类型需要考虑存储需求，准确性和速度。

（3） 如果您使用的信用卡号或其他包含16位或更多位数的数字代码，则必须使用文本格式，因为Excel的精度最高为15位，并且会将15位以下的任何数字四舍五入为整数零。