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

Вход

Регистрация

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

 

= Мир MS Excel/Долгий перенос строк по пустым ячейкам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Долгий перенос строк по пустым ячейкам (Макросы/Sub)
Долгий перенос строк по пустым ячейкам
xpyct Дата: Суббота, 06.10.2018, 01:22 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Пару дней поизучал примеры, составил что то годное, но долгое.
Задумка следующая:
Шаг1: Если в столбце H есть пустая ячейка то всю строку переносим на Лист2
Шаг2: Если в столбце J есть пустая ячейка то всю строку переносим на Лист3
Шаг3: А дальше идет наведение красоты (название столбцов и переименование листа), как смог так и сделал, главное работает :)

Третий шаг, проходит быстро, а вот первые два достаточно долго. Если строк будет в районе 5 тысяч, то задача будет длится минут пять, смысл этой задумки теряется.

[vba]
Код
Sub Макрос13()
'
' Макрос13 Макрос
'
' Сочетание клавиш: Ctrl+Shift+A
'

    
Dim iLastRow As Long, jLastRow As Long, i As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Лист2")
        jLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(jLastRow + 1, 11)).Clear
        jLastRow = 1
        For i = 2 To iLastRow
            If Cells(i, 8) = "" Then

                        Union(Range(Cells(i, 1), Cells(i, 2)), Range(Cells(i, 5), Cells(i, 6))).Copy .Cells(jLastRow + 1, 1)
                        jLastRow = jLastRow + 1
                    End If

        Next
        
    End With
    
    With Sheets("Лист3")
        jLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(jLastRow + 1, 11)).Clear
        jLastRow = 1
        For i = 2 To iLastRow
            If Cells(i, 10) = "" Then

                        Union(Range(Cells(i, 1), Cells(i, 2)), Range(Cells(i, 5), Cells(i, 6))).Copy .Cells(jLastRow + 1, 1)
                        jLastRow = jLastRow + 1
                    End If
        Next
        
    End With
    Range("A1,B1,E1,F1,H1").Select
    Range("H1").Activate
    Selection.Copy
    Sheets("Лист2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Лист1").Select
    Range("A1,B1,E1,F1").Select
    Range("F1").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Лист3").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B16").Select
    Sheets("Лист2").Select
    Sheets("Лист2").Name = "Для прайса"
    Sheets("Лист3").Select
    Sheets("Лист3").Name = "Для поставщика"
End Sub
[/vba]

Как ускорить можно?
К сообщению приложен файл: 1-2-.xlsx (89.8 Kb)


Сообщение отредактировал xpyct - Суббота, 06.10.2018, 01:23
 
Ответить
СообщениеПару дней поизучал примеры, составил что то годное, но долгое.
Задумка следующая:
Шаг1: Если в столбце H есть пустая ячейка то всю строку переносим на Лист2
Шаг2: Если в столбце J есть пустая ячейка то всю строку переносим на Лист3
Шаг3: А дальше идет наведение красоты (название столбцов и переименование листа), как смог так и сделал, главное работает :)

Третий шаг, проходит быстро, а вот первые два достаточно долго. Если строк будет в районе 5 тысяч, то задача будет длится минут пять, смысл этой задумки теряется.

[vba]
Код
Sub Макрос13()
'
' Макрос13 Макрос
'
' Сочетание клавиш: Ctrl+Shift+A
'

    
Dim iLastRow As Long, jLastRow As Long, i As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Лист2")
        jLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(jLastRow + 1, 11)).Clear
        jLastRow = 1
        For i = 2 To iLastRow
            If Cells(i, 8) = "" Then

                        Union(Range(Cells(i, 1), Cells(i, 2)), Range(Cells(i, 5), Cells(i, 6))).Copy .Cells(jLastRow + 1, 1)
                        jLastRow = jLastRow + 1
                    End If

        Next
        
    End With
    
    With Sheets("Лист3")
        jLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(jLastRow + 1, 11)).Clear
        jLastRow = 1
        For i = 2 To iLastRow
            If Cells(i, 10) = "" Then

                        Union(Range(Cells(i, 1), Cells(i, 2)), Range(Cells(i, 5), Cells(i, 6))).Copy .Cells(jLastRow + 1, 1)
                        jLastRow = jLastRow + 1
                    End If
        Next
        
    End With
    Range("A1,B1,E1,F1,H1").Select
    Range("H1").Activate
    Selection.Copy
    Sheets("Лист2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Лист1").Select
    Range("A1,B1,E1,F1").Select
    Range("F1").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Лист3").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B16").Select
    Sheets("Лист2").Select
    Sheets("Лист2").Name = "Для прайса"
    Sheets("Лист3").Select
    Sheets("Лист3").Name = "Для поставщика"
End Sub
[/vba]

Как ускорить можно?
Автор - xpyct
Дата добавления - 06.10.2018 в 01:22
Pelena Дата: Суббота, 06.10.2018, 08:53 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19182
Репутация: 4420 ±
Замечаний: ±

Excel 365 & Mac Excel
И Вам здравствуйте.
Можно использовать массивы
К сообщению приложен файл: 1-2-.xlsm (98.8 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеИ Вам здравствуйте.
Можно использовать массивы
Автор - Pelena
Дата добавления - 06.10.2018 в 08:53
boa Дата: Суббота, 06.10.2018, 11:30 | Сообщение № 3
Группа: Друзья
Ранг: Ветеран
Сообщений: 550
Репутация: 167 ±
Замечаний: 0% ±

365
я бы еще и селекты поубирал
[vba]
Код
    Sheets("Лист1").Range("A1,B1,E1,F1,H1").Copy Sheets("Лист2").Range("A1")
    Sheets("Лист1").Range("A1,B1,E1,F1").Copy Sheets("Лист3").Range("A1")
    Sheets("Лист2").Name = "Для прайса"
    Sheets("Лист3").Name = "Для поставщика"
[/vba]

 
Ответить
Сообщениея бы еще и селекты поубирал
[vba]
Код
    Sheets("Лист1").Range("A1,B1,E1,F1,H1").Copy Sheets("Лист2").Range("A1")
    Sheets("Лист1").Range("A1,B1,E1,F1").Copy Sheets("Лист3").Range("A1")
    Sheets("Лист2").Name = "Для прайса"
    Sheets("Лист3").Name = "Для поставщика"
[/vba]
Автор - boa
Дата добавления - 06.10.2018 в 11:30
xpyct Дата: Суббота, 06.10.2018, 19:57 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Огромное спасибо.
 
Ответить
СообщениеОгромное спасибо.
Автор - xpyct
Дата добавления - 06.10.2018 в 19:57
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Долгий перенос строк по пустым ячейкам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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