Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA: записать формулу из ячейки в массив и выгрузить потом на новый лист
 
#1
23.08.2018 11:42:09
Приветствую!
Макрос выдает ошибку(1004) при переносе таблицы на новый лист. Останавливается на ячейки которая содержит сл функцию:
Код
=СЧЁТЕСЛИ('C:\Users\vasilenko.a\Desktop\Мониторинг рынка\Анализ мониторинга\[Реестр.xlsb]Реестр'!$Q$2:$Q$920;"*Tplast Nexus Elsi*")

Но ячейку с функцией обрабатывает:

Код
='C:\Users\vasilenko.a\Desktop\Мониторинг рынка\Анализ мониторинга\[Аналитика.xlsb]Статистика'!F3

Пробовал с закрытой , открытой , удалял реестр из папки и т.д , ошибка не ушла.

Макрос ругается на сл строчку:

Код
 Cells(i, j).Value = mass(i - 1, j)

Хотел сделать редизайнер таблицы. В чем может быть проблема ?
Заранее спасибо!

Макрос:
Код
Sub fltbl()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
For i = 2 To a + 1
    For j = 1 To 7
     Cells(i, j).Value = mass(i - 1, j)
    Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Изменено: Xat - 23.08.2018 11:44:55
 
 
 
#2
23.08.2018 11:50:51
Цитата
Xat написал:
Cells(i, j).Value = mass(i - 1, j)
Скорее всего у вас:
1.массив пустой.
2.проверте размерность. как вариант он может быть
Код
mass(1)(i,j)
Изменено: ivanok_v2 - 23.08.2018 11:52:06
 
 
 
#3
23.08.2018 11:55:44
Правильно Вас понял? :
Код
Cells(i, j).Value = mass(i - 1, j)

Заменил на:
Код
    Cells(i, j).Value = mass(1)(i, j)

Ошибка (9) ругается на туже строчку.

Что может значить что массив пустой ( в макросах я ноль) ?

Изменено: Xat - 23.08.2018 11:56:42
 
 
 
#4
23.08.2018 12:02:04
дополню. Код писал я в одной из предыдущих тем.
Массив не пустой. В mass(a, 7)  записывается формула со СЧЕТЕСЛИ. При выгрузке ошибка. Причем у меня ошибки нет, формула переносится со значением #VALUE!, у автора ТС не переносится вообще.
Формула в mass(a, 5) обрабатывается нормально, там просто ссылка на ячейку в другой книге, без вычислений.
Пробовали запускать макрос с открытой книгой, на которую ссылка в СЧЕТЕСЛИ, закрытой, перемещать книгу в другую папку (по аналогии - у меня книги нет, и работает), в общем, танцы с бубном какие-то...
 
 
 
#5
23.08.2018 12:04:57
Первоначально была выгрузка массива через Resize, потом сделал циклом. Результат один - выгружается первая строка массива, 6 элементов, на 7-м ошибка
 
 
 
#6
23.08.2018 12:10:07
yozhik, Xat, можете показать debug (в редакторе VBE, окно Locals) значений массива?
 
 
 
#7
23.08.2018 12:12:42
ivanok_v2, это уже я все проверял...у меня ошибки нет, а=1710. Ошибка при выгрузке сразу в cells(2,7).value=mass(1,7), если без переменных
Изменено: yozhik - 23.08.2018 15:18:30
 
 
 
#8
23.08.2018 12:14:55
ivanok_v2,У Вас тоже , макрос срабатывает без проблем ?  
 
 
 
#9
23.08.2018 12:24:45
Цитата
Xat написал:
ivanok_v2 ,У Вас тоже , макрос срабатывает без проблем ?  
не работает, так будет норм.
Код
     If j = 5 Or j = 7 Then
        Cells(i, j).FormulaLocal = mass(i - 1, j)
     Else
        Cells(i, j).Value = mass(i - 1, j)
     End If
Изменено: ivanok_v2 - 23.08.2018 12:25:14
 
 
 
#10
23.08.2018 12:35:11
ivanok_v2,Это куда необходимо вставить или что заменить этим ?
 
 
 
#11
23.08.2018 12:38:26
Цитата
Xat написал:
Это куда необходимо вставить или что заменить этим ?
Код
     For j = 1 To 7
        If j = 5 Or j = 7 Then 
           Cells(i, j).FormulaLocal = mass(i - 1, j)
        Else
           Cells(i, j).Value = mass(i - 1, j)
        End If
     Next
 
 
 
#12
23.08.2018 12:51:00
Не сработал(((
Правильно Вас понял?
Код
Sub fltbl()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
 If j = 5 Or j = 7 Then
        Cells(i, j).FormulaLocal = mass(i - 1, j)
     Else
        Cells(i, j).Value = mass(i - 1, j)
     End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Изменено: Xat - 23.08.2018 12:51:11
 
 
 
#13
23.08.2018 12:53:34
Цитата
Xat написал:
Не сработал(((
упущено
Код
 For j = 1 To 7
Изменено: ivanok_v2 - 23.08.2018 12:53:49
 
 
 
#14
23.08.2018 14:37:26
Не понимаю , у меня не работает
Где я косячу!?((
Можете скинуть  рабочий макрос целиком ?
Код:
Код
Sub fltbl()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
     For j = 1 To 7
        If j = 5 Or j = 7 Then
           Cells(i, j).FormulaLocal = mass(i - 1, j)
        Else
           Cells(i, j).Value = mass(i - 1, j)
        End If
     Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Изменено: Xat - 23.08.2018 14:38:30
 
 
 
#15
23.08.2018 14:45:22
Код
Sub fltbl()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
     For j = 1 To 7
        If j = 5 Or j = 7 Then
           Cells(i, j).FormulaLocal = mass(i - 1, j)
        Else
           Cells(i, j).Value = mass(i - 1, j)
        End If
     Next
'Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
 
 
#16
23.08.2018 14:49:55
Теперь я получил рабочую строку , одну , внизу и все ((  
 
 
 
#17
23.08.2018 14:52:46
Вот что хочу получить , так получилось у yozhik
Изменено: Xat - 23.08.2018 14:53:28
 
 
 
#18
23.08.2018 14:58:23
Код
Sub fltbl()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
For i = 2 To a + 1
     For j = 1 To 7
        If j = 5 Or j = 7 Then
           Cells(i, j).FormulaLocal = mass(i - 1, j)
        Else
           Cells(i, j).Value = mass(i - 1, j)
        End If
     Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub


исправил
Изменено: ivanok_v2 - 23.08.2018 14:59:27
 
 
 
#19
23.08.2018 15:17:39
ivanok_v2,Уфф, это случилось )))))
Спасибо большое за помощь))))
yozhik, Спасибо за помощь и участие)))
 
 
 
Страницы: 1
Наверх