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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос данных после автофильтра - Мир MS Excel

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

Excel 2007
Добрый день.
Есть рабочий макрос по жеребьевке спортсменов.
Обработка идёт путем переборки необходимых разделов (К-1, ЛОУ-кик, Фул) по циклам с учетом возрастных (параметр "j") и весовых категорий (параметр "i") с вложенными циклами с копированием на соответствующие листы.
При этом данные переносятся через буфер обмена, что тормозит систему.
Есть ли вариант обрабатывать данные через массив для ускорения работы

Заранее благодарен.
К сообщению приложен файл: turnir_00_test_.xlsb(87.6 Kb)


Сообщение отредактировал berya - Вторник, 28.08.2018, 16:03
 
Ответить
СообщениеДобрый день.
Есть рабочий макрос по жеребьевке спортсменов.
Обработка идёт путем переборки необходимых разделов (К-1, ЛОУ-кик, Фул) по циклам с учетом возрастных (параметр "j") и весовых категорий (параметр "i") с вложенными циклами с копированием на соответствующие листы.
При этом данные переносятся через буфер обмена, что тормозит систему.
Есть ли вариант обрабатывать данные через массив для ускорения работы

Заранее благодарен.

Автор - berya
Дата добавления - 28.08.2018 в 13:22
_Boroda_ Дата: Вторник, 28.08.2018, 13:41 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13487
Репутация: 5522 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Конкретный вопрос по теме
Цитата
Перенос данных после автофильтра
какой?


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеКонкретный вопрос по теме
Цитата
Перенос данных после автофильтра
какой?

Автор - _Boroda_
Дата добавления - 28.08.2018 в 13:41
berya Дата: Вторник, 28.08.2018, 13:59 | Сообщение № 3
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
После автфильтра переносится по листам. В данном случае листы:
[vba]
Код
iList = Array("К_1_Б", "Лоу_Кік_Б", "ФК_Б")
[/vba].
алгоритм - проходит по категории К-1 - возрастные категории от 1 до 4 параметр в цикле "j" - если находит проходит весовые категории - параметр "i". и переносит на соответствующий лист. После этого идет обработка по ЛОУ-КИК и Фул


Сообщение отредактировал Pelena - Воскресенье, 02.09.2018, 06:29
 
Ответить
СообщениеПосле автфильтра переносится по листам. В данном случае листы:
[vba]
Код
iList = Array("К_1_Б", "Лоу_Кік_Б", "ФК_Б")
[/vba].
алгоритм - проходит по категории К-1 - возрастные категории от 1 до 4 параметр в цикле "j" - если находит проходит весовые категории - параметр "i". и переносит на соответствующий лист. После этого идет обработка по ЛОУ-КИК и Фул

Автор - berya
Дата добавления - 28.08.2018 в 13:59
_Boroda_ Дата: Вторник, 28.08.2018, 14:42 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13487
Репутация: 5522 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
berya, почти 5 лет!!! на форуме, а Правила до сих пор не прочитали?


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщениеberya, почти 5 лет!!! на форуме, а Правила до сих пор не прочитали?

Автор - _Boroda_
Дата добавления - 28.08.2018 в 14:42
berya Дата: Вторник, 28.08.2018, 15:01 | Сообщение № 5
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
_Boroda_, простите, но не совсем понимаю какой именно пункт не соблюден?
 
Ответить
Сообщение_Boroda_, простите, но не совсем понимаю какой именно пункт не соблюден?

Автор - berya
Дата добавления - 28.08.2018 в 15:01
_Boroda_ Дата: Вторник, 28.08.2018, 15:26 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13487
Репутация: 5522 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
3


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение3

Автор - _Boroda_
Дата добавления - 28.08.2018 в 15:26
berya Дата: Вторник, 28.08.2018, 15:41 | Сообщение № 7
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
_Boroda_, П. 3. Кратко, но ёмко опишите задачу в теле поста - оптимизация работы макроса
ВСЕГДА прикладывайте файл-пример - файл приложен
 
Ответить
Сообщение_Boroda_, П. 3. Кратко, но ёмко опишите задачу в теле поста - оптимизация работы макроса
ВСЕГДА прикладывайте файл-пример - файл приложен

Автор - berya
Дата добавления - 28.08.2018 в 15:41
StoTisteg Дата: Вторник, 28.08.2018, 15:49 | Сообщение № 8
Группа: Авторы
Ранг: Старожил
Сообщений: 1038
Репутация: 88 ±
Замечаний: 0% ±

Excel 2010
berya, это кратко, ёмко и не имеет отношения к теме :)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщениеberya, это кратко, ёмко и не имеет отношения к теме :)

Автор - StoTisteg
Дата добавления - 28.08.2018 в 15:49
InExSu Дата: Суббота, 01.09.2018, 22:50 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 419
Репутация: 51 ±
Замечаний: 20% ±

Excel 2010
Привет!
ЛОУ-кик

Давайте попробуем набить Вам ... руку на избавление от Select
Пожалуйста, замените
[vba]
Код
Sub shapka()
...
End Sub
[/vba]
на
[vba]
Код
Sub shapka(rng As Range)
    With rng
        .Borders.LineStyle = True
        .Borders.Weight = xlThin
        .Interior.ColorIndex = 35
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cambria"
            .FontStyle = "обычный"
            .Size = 10
            .Bold = True
        End With
    End With
End Sub
[/vba]

И к вызову shapka добавьте Selection. Должно получиться:
[vba]
Код
'''---------------------------------------------------------------------------------------
shapka Selection
'''---------------------------------------------------------------------------------------
[/vba]
Если получится, продолжим ...


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеПривет!
ЛОУ-кик

Давайте попробуем набить Вам ... руку на избавление от Select
Пожалуйста, замените
[vba]
Код
Sub shapka()
...
End Sub
[/vba]
на
[vba]
Код
Sub shapka(rng As Range)
    With rng
        .Borders.LineStyle = True
        .Borders.Weight = xlThin
        .Interior.ColorIndex = 35
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cambria"
            .FontStyle = "обычный"
            .Size = 10
            .Bold = True
        End With
    End With
End Sub
[/vba]

И к вызову shapka добавьте Selection. Должно получиться:
[vba]
Код
'''---------------------------------------------------------------------------------------
shapka Selection
'''---------------------------------------------------------------------------------------
[/vba]
Если получится, продолжим ...

Автор - InExSu
Дата добавления - 01.09.2018 в 22:50
InExSu Дата: Суббота, 01.09.2018, 23:09 | Сообщение № 10
Группа: Проверенные
Ранг: Обитатель
Сообщений: 419
Репутация: 51 ±
Замечаний: 20% ±

Excel 2010
Код от
[vba]
Код
Gr = Sheets("список").Range("K3").End(xlDown).Value
' по
Range("A4:K4").Resize(v).Copy Worksheets(Sname).Range(D)
[/vba]
Попробуйте заменить на
[vba]
Код
                    Gr = Sheets("список").Range("K3").End(xlDown).Value
                    With Sheets(Sname)
                        With .Range("E65535")
                            x = .End(xlUp).Row    'строка
                            y = .End(xlUp).Column    'столбец
                            D = .End(xlUp).Address(0, 0)
                        End With
                        With .Cells(x + 2, y - 4)
                            .Resize(1, 14).Merge
                            .FormulaR1C1 = UCase(param & " серед:" & " " & rn & " " & rn1 & " " & " - " & " " & rn2 & " " & "років," & " " & "Вагова категорія" & " " & VG2 & " " & VG1 & " " & "кг." & ", група" & " " & """" & Gr & """")
                            shapka .Resize(1, 14)
                        End With
                        D = .Range("A65535").End(xlUp).Offset(1, 0).Offset(0, 4).Address(0, 0)
                        ' Call Rng2Array(Список.AutoFilter.Range.SpecialCells(xlCellTypeVisible), 0, .Range(D))
                        v = Sheets("список").Range("A65535").End(xlUp).Row
                        Sheets("список").Range("A4:K4").Resize(v).Copy .Range(D)
                    End With
[/vba]


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеКод от
[vba]
Код
Gr = Sheets("список").Range("K3").End(xlDown).Value
' по
Range("A4:K4").Resize(v).Copy Worksheets(Sname).Range(D)
[/vba]
Попробуйте заменить на
[vba]
Код
                    Gr = Sheets("список").Range("K3").End(xlDown).Value
                    With Sheets(Sname)
                        With .Range("E65535")
                            x = .End(xlUp).Row    'строка
                            y = .End(xlUp).Column    'столбец
                            D = .End(xlUp).Address(0, 0)
                        End With
                        With .Cells(x + 2, y - 4)
                            .Resize(1, 14).Merge
                            .FormulaR1C1 = UCase(param & " серед:" & " " & rn & " " & rn1 & " " & " - " & " " & rn2 & " " & "років," & " " & "Вагова категорія" & " " & VG2 & " " & VG1 & " " & "кг." & ", група" & " " & """" & Gr & """")
                            shapka .Resize(1, 14)
                        End With
                        D = .Range("A65535").End(xlUp).Offset(1, 0).Offset(0, 4).Address(0, 0)
                        ' Call Rng2Array(Список.AutoFilter.Range.SpecialCells(xlCellTypeVisible), 0, .Range(D))
                        v = Sheets("список").Range("A65535").End(xlUp).Row
                        Sheets("список").Range("A4:K4").Resize(v).Copy .Range(D)
                    End With
[/vba]

Автор - InExSu
Дата добавления - 01.09.2018 в 23:09
Pelena Дата: Воскресенье, 02.09.2018, 06:30 | Сообщение № 11
Группа: Админы
Ранг: Местный житель
Сообщений: 13216
Репутация: 2908 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Код в третьем посте отредактировала, т.к. автор уже не сможет внести изменения в пост. На будущее: оформляйте коды и формулы тегами


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеКод в третьем посте отредактировала, т.к. автор уже не сможет внести изменения в пост. На будущее: оформляйте коды и формулы тегами

Автор - Pelena
Дата добавления - 02.09.2018 в 06:30
berya Дата: Воскресенье, 02.09.2018, 09:34 | Сообщение № 12
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
InExSu, Доброе утро. Ваш вариант работает.
По поводу Select - согласен - стараюсь избавляться.
У меня в этой процедуре самое слабое место - куча фильтров и копирование на другой лист. Я пытался передать результаты автофильтра через массивы. Но в некоторых местах у меня шло с ошибками - вернулся к проверенному варианту через COPY.
Большое спасибо за внимание к моей проблеме
 
Ответить
СообщениеInExSu, Доброе утро. Ваш вариант работает.
По поводу Select - согласен - стараюсь избавляться.
У меня в этой процедуре самое слабое место - куча фильтров и копирование на другой лист. Я пытался передать результаты автофильтра через массивы. Но в некоторых местах у меня шло с ошибками - вернулся к проверенному варианту через COPY.
Большое спасибо за внимание к моей проблеме

Автор - berya
Дата добавления - 02.09.2018 в 09:34
berya Дата: Воскресенье, 02.09.2018, 09:34 | Сообщение № 13
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Pelena, Доброе утро. Замечание принял - исправлюсь
 
Ответить
СообщениеPelena, Доброе утро. Замечание принял - исправлюсь

Автор - berya
Дата добавления - 02.09.2018 в 09:34
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных после автофильтра (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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