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，并明确声明变量。您可以按照这些步骤进行配置，因此编辑器会自动添加此行。以这种方式，您意识到并能够管理变量，根据其内存分配来处理数据类型。

a。在Visual Basic编辑器中，单击工具，然后单击选项。

b。检查需要变量声明。

它会通过，而不是普通的老将军多一点表现错误信息（例如值过大）已经相当不错了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个字节，整数 数据类型是2个字节，而通用16字节Variant数据 类型可以使用VBA 转换函数CDec转换为12字节的十进制数据类型。 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.