Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Увеличить охват (массив) макроса. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Увеличить охват (массив) макроса. (Макросы/Sub)
Увеличить охват (массив) макроса.
zegor Дата: Пятница, 10.08.2018, 16:47 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 118
Репутация: 1 ±
Замечаний: 0% ±

Excel 2007
Привет, excelworld. Есть макрос, он "блочно" перебрасывает данные с одного листа на другой по критериям (есть список). Собственно у меня получается охватывать только 67 критериев. При попытке добавить критерий заканчивается строка и последнее добавление окрашивается в красный цвет. Если это игнорировать макрос отказывается работать. Помоги пожалуйста преодолеть лимит в 67 критериев.
[vba]
Код
Sub perenos_1_67()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim MyArr
Dim Found_b As Range
Dim iAdr As String
MyArr = Array(Cells(2, 60), Cells(3, 60), Cells(4, 60), Cells(5, 60), Cells(6, 60), Cells(7, 60), Cells(8, 60), Cells(9, 60), Cells(10, 60), Cells(11, 60), Cells(12, 60), Cells(13, 60), Cells(14, 60), Cells(15, 60), Cells(16, 60), Cells(17, 60), Cells(18, 60), Cells(19, 60), Cells(20, 60), Cells(21, 60), Cells(22, 60), Cells(23, 60), Cells(24, 60), Cells(25, 60), Cells(26, 60), Cells(27, 60), Cells(28, 60), Cells(29, 60), Cells(30, 60), Cells(31, 60), Cells(32, 60), Cells(33, 60), Cells(34, 60), Cells(35, 60), Cells(36, 60), Cells(37, 60), Cells(38, 60), Cells(39, 60), Cells(40, 60), Cells(41, 60), Cells(42, 60), Cells(43, 60), Cells(44, 60), Cells(45, 60), Cells(46, 60), Cells(47, 60), Cells(48, 60), Cells(49, 60), Cells(50, 60), Cells(51, 60), Cells(52, 60), Cells(53, 60), Cells(54, 60), Cells(55, 60), Cells(56, 60), Cells(57, 60), Cells(58, 60), Cells(59, 60), Cells(60, 60), Cells(61, 60), Cells(62, 60), Cells(63, 60), Cells(64, 60), Cells(65, 60), Cells(66, 60), Cells(67, 60), Cells(68, 60))
With Worksheets("zero")
    .Cells.Clear
    j = 1
    For i = 0 To UBound(MyArr)
    Set Found_b = Columns("A:B").Find(MyArr(i), , xlValues, xlWhole)
    iAdr = Found_b.Address
        k = 1
        Do
        Range(Cells(Found_b.Row, 1), Cells(Found_b.Row, 26)).Copy .Cells(k, j)
        Set Found_b = Columns("A:B").FindNext(Found_b)
        k = k + 1
        Loop While Found_b.Address <> iAdr
        j = j + 27
    Next
End With
End Sub
[/vba]


Сообщение отредактировал zegor - Пятница, 10.08.2018, 16:48
 
Ответить
СообщениеПривет, excelworld. Есть макрос, он "блочно" перебрасывает данные с одного листа на другой по критериям (есть список). Собственно у меня получается охватывать только 67 критериев. При попытке добавить критерий заканчивается строка и последнее добавление окрашивается в красный цвет. Если это игнорировать макрос отказывается работать. Помоги пожалуйста преодолеть лимит в 67 критериев.
[vba]
Код
Sub perenos_1_67()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim MyArr
Dim Found_b As Range
Dim iAdr As String
MyArr = Array(Cells(2, 60), Cells(3, 60), Cells(4, 60), Cells(5, 60), Cells(6, 60), Cells(7, 60), Cells(8, 60), Cells(9, 60), Cells(10, 60), Cells(11, 60), Cells(12, 60), Cells(13, 60), Cells(14, 60), Cells(15, 60), Cells(16, 60), Cells(17, 60), Cells(18, 60), Cells(19, 60), Cells(20, 60), Cells(21, 60), Cells(22, 60), Cells(23, 60), Cells(24, 60), Cells(25, 60), Cells(26, 60), Cells(27, 60), Cells(28, 60), Cells(29, 60), Cells(30, 60), Cells(31, 60), Cells(32, 60), Cells(33, 60), Cells(34, 60), Cells(35, 60), Cells(36, 60), Cells(37, 60), Cells(38, 60), Cells(39, 60), Cells(40, 60), Cells(41, 60), Cells(42, 60), Cells(43, 60), Cells(44, 60), Cells(45, 60), Cells(46, 60), Cells(47, 60), Cells(48, 60), Cells(49, 60), Cells(50, 60), Cells(51, 60), Cells(52, 60), Cells(53, 60), Cells(54, 60), Cells(55, 60), Cells(56, 60), Cells(57, 60), Cells(58, 60), Cells(59, 60), Cells(60, 60), Cells(61, 60), Cells(62, 60), Cells(63, 60), Cells(64, 60), Cells(65, 60), Cells(66, 60), Cells(67, 60), Cells(68, 60))
With Worksheets("zero")
    .Cells.Clear
    j = 1
    For i = 0 To UBound(MyArr)
    Set Found_b = Columns("A:B").Find(MyArr(i), , xlValues, xlWhole)
    iAdr = Found_b.Address
        k = 1
        Do
        Range(Cells(Found_b.Row, 1), Cells(Found_b.Row, 26)).Copy .Cells(k, j)
        Set Found_b = Columns("A:B").FindNext(Found_b)
        k = k + 1
        Loop While Found_b.Address <> iAdr
        j = j + 27
    Next
End With
End Sub
[/vba]

Автор - zegor
Дата добавления - 10.08.2018 в 16:47
Pelena Дата: Пятница, 10.08.2018, 17:13 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 13140
Репутация: 2895 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
Может, массив так попробовать задать
[vba]
Код
MyArr = Cells(2, 60).Resize(68).Value
[/vba]
В Resize задавайте нужное кол-во строк


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Может, массив так попробовать задать
[vba]
Код
MyArr = Cells(2, 60).Resize(68).Value
[/vba]
В Resize задавайте нужное кол-во строк

Автор - Pelena
Дата добавления - 10.08.2018 в 17:13
zegor Дата: Пятница, 10.08.2018, 19:57 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 118
Репутация: 1 ±
Замечаний: 0% ±

Excel 2007
Pelena, вечер добрый. С вашей подсказкой ругается так "Subscript out of range"

[offtop]я просто заменил строку кода вашей[/offtop]


Сообщение отредактировал zegor - Пятница, 10.08.2018, 20:01
 
Ответить
СообщениеPelena, вечер добрый. С вашей подсказкой ругается так "Subscript out of range"

[offtop]я просто заменил строку кода вашей[/offtop]

Автор - zegor
Дата добавления - 10.08.2018 в 19:57
Pelena Дата: Пятница, 10.08.2018, 20:04 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 13140
Репутация: 2895 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Обращаться надо [vba]
Код
MyArr(i,1)
[/vba]
так как этот способ формирует двумерный массив.
Если не получится, прикладывайте файл с примером


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеОбращаться надо [vba]
Код
MyArr(i,1)
[/vba]
так как этот способ формирует двумерный массив.
Если не получится, прикладывайте файл с примером

Автор - Pelena
Дата добавления - 10.08.2018 в 20:04
zegor Дата: Пятница, 10.08.2018, 20:54 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 118
Репутация: 1 ±
Замечаний: 0% ±

Excel 2007
Гхм, правда пример не прикрепил. Исправляюсь.
Спасибо, Pelena.
К сообщению приложен файл: 1339388.xlsm(28.2 Kb)


Сообщение отредактировал zegor - Пятница, 10.08.2018, 20:55
 
Ответить
СообщениеГхм, правда пример не прикрепил. Исправляюсь.
Спасибо, Pelena.

Автор - zegor
Дата добавления - 10.08.2018 в 20:54
RAN Дата: Пятница, 10.08.2018, 21:21 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4854
Репутация: 971 ±
Замечаний: 0% ±

2010
Нижняя граница такого массива 1, а не 0. Ну, и как уже написала Pelena, индексов должно быть 2.
[vba]
Код
    For i = 1 To UBound(MyArr)
    Set Found_b = Columns("A:B").Find(MyArr(i, 1), , xlValues, xlWhole)
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеНижняя граница такого массива 1, а не 0. Ну, и как уже написала Pelena, индексов должно быть 2.
[vba]
Код
    For i = 1 To UBound(MyArr)
    Set Found_b = Columns("A:B").Find(MyArr(i, 1), , xlValues, xlWhole)
[/vba]

Автор - RAN
Дата добавления - 10.08.2018 в 21:21
zegor Дата: Пятница, 10.08.2018, 21:36 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 118
Репутация: 1 ±
Замечаний: 0% ±

Excel 2007
RAN, с вашим уточнением до меня дошло последнее сообщение от Pelena. Спасибо Pelena и RAN. Всё работает.
 
Ответить
СообщениеRAN, с вашим уточнением до меня дошло последнее сообщение от Pelena. Спасибо Pelena и RAN. Всё работает.

Автор - zegor
Дата добавления - 10.08.2018 в 21:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Увеличить охват (массив) макроса. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!