none
RunTime Error 7 - Out of Memory на ReDim массива VBA Excel 64 RRS feed

  • Вопрос

  • RunTime Error 7 - Out of Memory  на ReDim массива VBA Excel 64


    Добрый день! 

    Проблема в следующем: все данные с листа помещаю в массив, чтобы их быстрее обработать. На малых объемах все работает хорошо. На больших, близких к граничным, вылезает ошибка "RunTime Error 7 - Out of Memory". 

    Она вылезает или на ReDim массива, или на присвоении массиву диапазона с листа. 

    ПАМЯТИ 8 ГБ, Excel 64 РАЗРЯДНЫЙ, ОПЕРАЦИОНКА 64 РАЗРЯДНАЯ,Excel 2016
    ошибку даёт Redim на 111 533 строках и 1635 столбцах 

    на объёме маленьком ошибку не даёт (до 100 строк и до 100 столбцов) - работает нормально......

    Если ошибку отлавливать 

    On Error Resume Next
    If Err.Number <> 0 Then
    Err.Clear
    End If



    - то Excel виснит и  уходит в бесконечный цикл, постоянно увеличивая  занимаемую память. 



    код 
    Dim text_word2() As Variant
    x=1635
    ReDim text_word2(0 To kki, 0 To x)- место ошибки

    полный код:



    Private Sub CommandButton3_Click()
    Dim n As Long
    Dim nn As Long
    Dim find As String
    Dim kki, kkj As Integer
    
    Dim k, kk, ii, i, j, jj, l, ll, jjj, i1, i2, kkk, j1, j2, j3, i3, jj3, eqmax As Long
    Dim ii_find, jj_find, ii_text, jj_text As Long
    Dim Txt, txt2, txt_p, txt_col, txt_row, txt_out As String
    
    
         Dim Rng_find As Range
         Dim Rng_text As Range
         Dim Rng_substitution As Range
         Dim Rng_out As Range
         Dim theRange_out As Range
         Dim Delimiter As String
    
        Dim Find_word() As String
        Dim Find_word2() As String
        Dim text_word1() As String
        Dim text_word2() As Variant
    
        On Error Resume Next
        Set Rng_find = Range(RefEdit1.Value)
    
        Set Rng_text = Range(RefEdit2.Value)
        Set Rng_substitution = Range(RefEdit3.Value)
        Set Rng_out = Range(RefEdit4.Value)
        Delimiter = Me.TextBox1
            
        On Error GoTo 0
         
        
        If Rng_find Is Nothing Then
            MsgBox "вы не выбрали диапазон какие данные ищем"
            Err.Clear
        Else
        If Rng_text Is Nothing Then
            MsgBox "вы не выбрали диапазон в котором ищем данные "
            Err.Clear
        Else
        
          If Rng_out Is Nothing Then
             MsgBox "вы не выбрали диапазон куда выводить данные"
             Err.Clear
          Else
        
        Application.ScreenUpdating = False
        
        
          
        If myWord(Rng_text).imyRows > myWord(Rng_text).imyColumns Then 'если строк больше чем столбцов в тексте в котором ищем
        
       'раскладываем по словам искомый диапазон
        ii_find = myWord(Rng_find).imyRows
        jj_find = myWord(Rng_find).imyColumns
        
        
        ReDim Find_word(1 To ii_find, 0 To jj_find) ' 0-вой столбец фраза целиком
        Find_word = myWord(Rng_find).iFindword
        
         ' переводим в массив 2-ух строк
         ' 0 строка фраза целиком
         ' 1 строка разложение по словам
        ReDim Find_word2(0 To 2, 0 To (jj_find * ii_find))  '
        jjj = 1
       For i = 1 To ii_find
         For j = 1 To jj_find
           If ((Find_word(i, j) <> "") And (Find_word(i, j) <> " ") And (Find_word(i, j) <> Empty) And (Len(Find_word(i, j)) > 2)) Then
              Find_word2(0, jjj) = Find_word(i, 0)
              Find_word2(1, jjj) = Find_word(i, j)
              jjj = jjj + 1
           End If
         Next j
       Next i
      
        'раскладываем по словам  диапазон в котором ищем
        ii_text = myWord(Rng_text).imyRows
        jj_text = myWord(Rng_text).imyColumns
        ReDim text_word1(1 To ii_text, 0 To jj_text) ' 0-вой столбец фраза целиком
        text_word1 = myWord(Rng_text).iFindword
    '______________
    
    'определение % совпадения каждого слова в строке в масиве  text_word2(i, j)
    kkj = jj_text + jjj + 2
    kki = ii_text + 2
    ReDim text_word2(0 To kki, 0 To kkj)
    On Error Resume Next
    If Err.Number <> 0 Then
    Err.Clear
    End If
    
    
       '-составляем массив в котором будем сопоставлять
    
        For j = 0 To jj_text
             i2 = 3
            For i = 1 To (ii_text) 'заполнение массива
             
             text_word2(0, j) = "где ищем"
             
             text_word2(i2, j) = text_word1(i, j)
             i2 = i2 + 1
            Next i
          Next j
    ' первая строка - группы- искомые слова исходном виде- строка 0
    ' вторая строка - группы- искомые слова в разложенном виде - строка 1
       For i = 1 To 2 'заполнение массива
         kkk = jj_text + 1
          For jj = 1 To jjj
              text_word2(0, kkk) = "что ищем"
              text_word2(i, kkk) = Find_word2((i - 1), jj)
              kkk = kkk + 1
             Next jj
     
        Next i
      
      For i = 3 To i2 - 1 'получаем % совпадения искомых слов
      
           For jj = (jj_text + 1) To kkk
           eqmax = 0
             For jj3 = 1 To jj_text
              If text_word2(i, jj3) <> Empty Then
                 If Equality(CStr(text_word2(i, jj3)), CStr(text_word2(2, jj))) > eqmax Then
                    text_word2(i, jj) = CDbl(CDbl(Equality(CStr(text_word2(i, jj3)), CStr(text_word2(2, jj))) / Len(CStr(text_word2(2, jj)))))
                    
                    eqmax = Equality(CStr(text_word2(i, jj3)), (CStr(text_word2(2, jj))))
                 End If
                  If eqmax < 3 Then text_word2(i, jj) = ""
              End If
             Next jj3
            Next jj
         Next i
     
        
     
      ElseIf myWord(Rng_text).imyRows < myWord(Rng_text).imyColumns Then 'если столбцов больше чем строк в тексте в котором ищем
      
      Else
      
      
      End If
      
      
      'динамический расчёт вставляемого массива от заданной ячейки полбзователем
     
     txt_p = Substring(RefEdit4.Text, "!", 1)
     txt_col = Substring(Substring(RefEdit4.Text, "!", 2), "$", 2)
     txt2 = Substring(Substring(RefEdit4.Text, "!", 2), "$", 3)
     txt_row = Substring(txt2, ":", 1)
    
     i = jj_text + jjj + 2 + Int(Columns(txt_col).Column)
     
     txt_out = txt_col & txt_row & ":" & Trim(Substring(Cells(1, i).Address, "$", 2)) & Trim(Str((ii_text + 2) + Int(txt_row)))
    
    'вставка итогового массива
          ActiveWorkbook.ActiveSheet.Range(txt_out).Clear
           Set theRange_out = ActiveWorkbook.ActiveSheet.Range(txt_out)
             theRange_out = text_word2
          
               
          End If
        End If
      End If
    


          




    ВОПРОС БЫЛ КАК ОБОЙТИ Redim ? ИЛИ КАК ОТЛОВИТЬ ОШИБКУ "RunTime Error 7 - Out of Memory "...

    ТУТ ГЛЮК САМОГО VBA EXCEL В Redim на больших объёмах....

    ПОМОГИТЕ ПОЖАЛУЙСТА.
    ЗАРАНЕЕ СПАСИБО.



    • Изменено SvetaS_Love 18 июля 2015 г. 14:25
    16 июля 2015 г. 18:29

Ответы

  • Уверены что память банально не кончается? Если я правильно увидел выше, то у вас таблица о "111 533 строках и 1635 столбцах", а то это ~180 миллионов ячеек. Если каждая, скажем, по 100 байтов то это 18ГБ. 


    This posting is provided "AS IS" with no warranties, and confers no rights.

    18 июля 2015 г. 16:30
    Модератор

Все ответы

  • Посмотрите вот эту тему, там открывал и обрабатывал Excel файл, с большим количеством данных. Предлагаю считать файл полностью, можно с нужной позиции, затем начинать обработку, как пожелаете.
    16 июля 2015 г. 19:01
  • ТЕМУ посмотрела, там обработка идёт на VС++, а не  на VBA, ДА и у меня проблема не в считывании данных с файла, а в их занесении в динамический массив в процессе обработки. Т.е. проблема в заполнении динамического массива (размер которого заранее не известен) данными которые уже выбраны с листа ранее (в прошлых массивах)  с целью их последующей обработки. 
    16 июля 2015 г. 21:35
  • ТУТ ГЛЮК САМОГО VBA EXCEL В Redim на больших объёмах....
    18 июля 2015 г. 14:19
  • Уверены что память банально не кончается? Если я правильно увидел выше, то у вас таблица о "111 533 строках и 1635 столбцах", а то это ~180 миллионов ячеек. Если каждая, скажем, по 100 байтов то это 18ГБ. 


    This posting is provided "AS IS" with no warranties, and confers no rights.

    18 июля 2015 г. 16:30
    Модератор