VBA运行时错误7内存不足

Question

这可能在某处，我错过了，请告诉我。

运行我的宏后，我得到运行时错误7内存不足。经过调试，它就在这一行：

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

该代码旨在运行具有经度和纬度的机场列表，创建将被解释为圆圈的线段，并转换为.KML（由Google地球专业版读取）。

以下是代码的其余部分 - 如何清理这样的内容以避免内存泄漏？

所有答案都赞赏，或指向其他帖子。我知道这很多，所以也欢迎一般的建议！谢谢！

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编译器而言，通过更多表达错误消息（例如，值太大）而不是普通的旧一般内存不足，这将是非常好的像这样。无论如何，以下是解释导致此错误的可能原因的链接。

More memory was required than is available, or a 64K segment boundary was encountered. This error has the following causes and solutions:

  

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

     

您的模块或程序太大。

     

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

     

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

     

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

     

您正在运行终止和驻留程序。消除终止和驻留程序。

     

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

     

Publicvariables

的空间不足      

减少公共变量的数量。

（1）Excel specifications and limits.

（2）Numeric precision in Microsoft Excel.

  

VBA内的准确性   虽然Excel名义上默认使用8字节数字，但VBA有   各种数据类型。 Double数据类型是8个字节，即Integer   数据类型是2个字节，而通用的是16个字节的Variant数据   可以使用VBA将类型转换为12字节的十进制数据类型   转换函数CDec。[16]在VBA中选择变量类型   计算涉及考虑存储要求，准确性   和速度。

（3）If you are using credit card numbers, or other number codes that contain 16 digits or more, you must use a text format because Excel has a maximum of 15 digits of precision and will round any numbers that follow the 15th digit down to zero.