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

Вход

Регистрация

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

 

= Мир MS Excel/Выделение непустых ячеек до следующей пустой - Мир MS Excel

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

Excel 2013
Всем привет.
Пытаюсь решить такую задачу. Есть таблица, в которой в одном столбце данные в ячейках разбиты - должно быть в одной ячейке, но разбито на 2,3,4 и т.д (эти ячейки идут последовательно). Затем идет пустая ячейка, затем снова заполненные и т.д. Я хочу объединить последовательно идущие непустые ячейки. После пропускаются все пустые, выделяются все последовательно непустые и тоже объединяются и т.д. Макрос объединения у меня есть. Не знаю как реализовать поиск. Кто подскажет?
Пример приложил. Макрос объединения ячеек в примере присутствует.
К сообщению приложен файл: Primer1.xls (52.0 Kb)


Сообщение отредактировал drugojandrew - Воскресенье, 13.05.2018, 11:24
 
Ответить
СообщениеВсем привет.
Пытаюсь решить такую задачу. Есть таблица, в которой в одном столбце данные в ячейках разбиты - должно быть в одной ячейке, но разбито на 2,3,4 и т.д (эти ячейки идут последовательно). Затем идет пустая ячейка, затем снова заполненные и т.д. Я хочу объединить последовательно идущие непустые ячейки. После пропускаются все пустые, выделяются все последовательно непустые и тоже объединяются и т.д. Макрос объединения у меня есть. Не знаю как реализовать поиск. Кто подскажет?
Пример приложил. Макрос объединения ячеек в примере присутствует.

Автор - drugojandrew
Дата добавления - 13.05.2018 в 11:23
RAN Дата: Воскресенье, 13.05.2018, 13:13 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Вы уверены, что объединение нужно?
[vba]
Код
Sub Мяу()
    Dim rng As Range
    Dim i&, ii&, n&
    Dim s$
    n = Cells(Rows.Count, 2).End(xlUp).Row
    i = 1
    Columns(2).WrapText = True
    Application.DisplayAlerts = False

    Do While i <= n
        ii = i
        Do
            s = s & " " & Cells(i, 2).Value
            If rng Is Nothing Then
                Set rng = Cells(i, 2)
            Else
                Set rng = Union(rng, Cells(i, 2))
            End If
            i = i + 1
            DoEvents
        Loop Until IsEmpty(Cells(i, 2))
        If rng.Count > 1 Then
            s = LTrim(s)
            rng.Merge
            rng(1) = s
        End If
        s = ""
        Set rng = Nothing
        i = i + 1
        DoEvents
    Loop
    Application.DisplayAlerts = True

End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеВы уверены, что объединение нужно?
[vba]
Код
Sub Мяу()
    Dim rng As Range
    Dim i&, ii&, n&
    Dim s$
    n = Cells(Rows.Count, 2).End(xlUp).Row
    i = 1
    Columns(2).WrapText = True
    Application.DisplayAlerts = False

    Do While i <= n
        ii = i
        Do
            s = s & " " & Cells(i, 2).Value
            If rng Is Nothing Then
                Set rng = Cells(i, 2)
            Else
                Set rng = Union(rng, Cells(i, 2))
            End If
            i = i + 1
            DoEvents
        Loop Until IsEmpty(Cells(i, 2))
        If rng.Count > 1 Then
            s = LTrim(s)
            rng.Merge
            rng(1) = s
        End If
        s = ""
        Set rng = Nothing
        i = i + 1
        DoEvents
    Loop
    Application.DisplayAlerts = True

End Sub
[/vba]

Автор - RAN
Дата добавления - 13.05.2018 в 13:13
_Boroda_ Дата: Воскресенье, 13.05.2018, 13:53 | Сообщение № 3
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Вы уверены, что объединение нужно?

Вот меня тоже этот вопрос интересует. Сделал без объединения, просто сцепил все через пустую строку
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    r1_ = Range("B" & Rows.Count).End(xlUp).Row
    ar = Range("A1").Resize(r1_)
    For i = 1 To r1_
        If ar(i, 1) <> "" Then
            ar(n_ * 2 + 1, 1) = ar(i, 1)
            If i <> n_ * 2 + 1 Then: ar(i, 1) = Empty
            n_ = n_ + 1
        End If
    Next i
    Range("A1").Resize(r1_) = ar
    Columns("B:B").ColumnWidth = 255
    Range("B1:B" & r1_).Justify
    Columns("B:B").EntireColumn.AutoFit
    Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: 55_1.xls (68.5 Kb)


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

Вот меня тоже этот вопрос интересует. Сделал без объединения, просто сцепил все через пустую строку
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    r1_ = Range("B" & Rows.Count).End(xlUp).Row
    ar = Range("A1").Resize(r1_)
    For i = 1 To r1_
        If ar(i, 1) <> "" Then
            ar(n_ * 2 + 1, 1) = ar(i, 1)
            If i <> n_ * 2 + 1 Then: ar(i, 1) = Empty
            n_ = n_ + 1
        End If
    Next i
    Range("A1").Resize(r1_) = ar
    Columns("B:B").ColumnWidth = 255
    Range("B1:B" & r1_).Justify
    Columns("B:B").EntireColumn.AutoFit
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 13.05.2018 в 13:53
drugojandrew Дата: Вторник, 15.05.2018, 10:41 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Вы уверены, что объединение нужно?
И правда, объединение не обязательно. Главное чтобы все в одной ячейке было, а способ не важен.
За макрос спасибо, работает. Добавил ещё разъединение ячеек и получилось то, что хотел.
 
Ответить
Сообщение
Вы уверены, что объединение нужно?
И правда, объединение не обязательно. Главное чтобы все в одной ячейке было, а способ не важен.
За макрос спасибо, работает. Добавил ещё разъединение ячеек и получилось то, что хотел.

Автор - drugojandrew
Дата добавления - 15.05.2018 в 10:41
drugojandrew Дата: Вторник, 15.05.2018, 10:45 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Сделал без объединения, просто сцепил все через пустую строку
Это гораздо быстрее работает)) (Есть таблица, где нужно обработать тысяч 20 строк, тогда это особо заметно).
А как сделать так, чтобы он не удалял лишние пустые строки? Мне нужно чтобы в столбце А положение заполненных ячеек не менялось.
 
Ответить
Сообщение
Сделал без объединения, просто сцепил все через пустую строку
Это гораздо быстрее работает)) (Есть таблица, где нужно обработать тысяч 20 строк, тогда это особо заметно).
А как сделать так, чтобы он не удалял лишние пустые строки? Мне нужно чтобы в столбце А положение заполненных ячеек не менялось.

Автор - drugojandrew
Дата добавления - 15.05.2018 в 10:45
drugojandrew Дата: Вторник, 15.05.2018, 11:34 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Почему и зачем?

Мой пример - это часть большой таблицы, в которой еще много столбцов. Если смещаются данные в первых двух столбцах, то вся таблица едет.
 
Ответить
Сообщение
Почему и зачем?

Мой пример - это часть большой таблицы, в которой еще много столбцов. Если смещаются данные в первых двух столбцах, то вся таблица едет.

Автор - drugojandrew
Дата добавления - 15.05.2018 в 11:34
drugojandrew Дата: Вторник, 15.05.2018, 12:36 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Читайте Требования по составлению примера в Правилах форума

Ошибку понял. Пример подправил.
 
Ответить
Сообщение
Читайте Требования по составлению примера в Правилах форума

Ошибку понял. Пример подправил.

Автор - drugojandrew
Дата добавления - 15.05.2018 в 12:36
drugojandrew Дата: Вторник, 15.05.2018, 12:37 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Вот пример
К сообщению приложен файл: 55_2.xls (70.0 Kb)
 
Ответить
СообщениеВот пример

Автор - drugojandrew
Дата добавления - 15.05.2018 в 12:37
_Boroda_ Дата: Вторник, 15.05.2018, 13:15 | Сообщение № 9
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Тогда так
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    r1_ = Range("B" & Rows.Count).End(xlUp).Row
    ar = Range("A1").Resize(r1_)
    c1_ = Cells(1, Columns.Count).End(1).Column - 2
    ar1 = Range("C1").Resize(r1_, c1_)
    For i = 1 To r1_
        If ar(i, 1) <> "" Then
            ar(n_ * 2 + 1, 1) = ar(i, 1)
            For j = 1 To c1_
                ar1(n_ * 2 + 1, j) = ar1(i, j)
            Next j
            If i <> n_ * 2 + 1 Then
                ar(i, 1) = Empty
                For j = 1 To c1_
                    ar1(i, j) = Empty
                Next j
            End If
            n_ = n_ + 1
        End If
    Next i
    Range("A1").Resize(r1_) = ar
    Range("C1").Resize(r1_, c1_) = ar1
    Columns("B:B").ColumnWidth = 255
    Range("B1:B" & r1_).Justify
    Columns("B:B").EntireColumn.AutoFit
    Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: 55_3.xls (78.0 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТогда так
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    r1_ = Range("B" & Rows.Count).End(xlUp).Row
    ar = Range("A1").Resize(r1_)
    c1_ = Cells(1, Columns.Count).End(1).Column - 2
    ar1 = Range("C1").Resize(r1_, c1_)
    For i = 1 To r1_
        If ar(i, 1) <> "" Then
            ar(n_ * 2 + 1, 1) = ar(i, 1)
            For j = 1 To c1_
                ar1(n_ * 2 + 1, j) = ar1(i, j)
            Next j
            If i <> n_ * 2 + 1 Then
                ar(i, 1) = Empty
                For j = 1 To c1_
                    ar1(i, j) = Empty
                Next j
            End If
            n_ = n_ + 1
        End If
    Next i
    Range("A1").Resize(r1_) = ar
    Range("C1").Resize(r1_, c1_) = ar1
    Columns("B:B").ColumnWidth = 255
    Range("B1:B" & r1_).Justify
    Columns("B:B").EntireColumn.AutoFit
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 15.05.2018 в 13:15
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выделение непустых ячеек до следующей пустой (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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