Всем привет. Пытаюсь решить такую задачу. Есть таблица, в которой в одном столбце данные в ячейках разбиты - должно быть в одной ячейке, но разбито на 2,3,4 и т.д (эти ячейки идут последовательно). Затем идет пустая ячейка, затем снова заполненные и т.д. Я хочу объединить последовательно идущие непустые ячейки. После пропускаются все пустые, выделяются все последовательно непустые и тоже объединяются и т.д. Макрос объединения у меня есть. Не знаю как реализовать поиск. Кто подскажет? Пример приложил. Макрос объединения ячеек в примере присутствует.
Всем привет. Пытаюсь решить такую задачу. Есть таблица, в которой в одном столбце данные в ячейках разбиты - должно быть в одной ячейке, но разбито на 2,3,4 и т.д (эти ячейки идут последовательно). Затем идет пустая ячейка, затем снова заполненные и т.д. Я хочу объединить последовательно идущие непустые ячейки. После пропускаются все пустые, выделяются все последовательно непустые и тоже объединяются и т.д. Макрос объединения у меня есть. Не знаю как реализовать поиск. Кто подскажет? Пример приложил. Макрос объединения ячеек в примере присутствует.drugojandrew
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
Вот меня тоже этот вопрос интересует. Сделал без объединения, просто сцепил все через пустую строку [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]
Код
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
И правда, объединение не обязательно. Главное чтобы все в одной ячейке было, а способ не важен. За макрос спасибо, работает. Добавил ещё разъединение ячеек и получилось то, что хотел.
И правда, объединение не обязательно. Главное чтобы все в одной ячейке было, а способ не важен. За макрос спасибо, работает. Добавил ещё разъединение ячеек и получилось то, что хотел.drugojandrew
Сделал без объединения, просто сцепил все через пустую строку
Это гораздо быстрее работает)) (Есть таблица, где нужно обработать тысяч 20 строк, тогда это особо заметно). А как сделать так, чтобы он не удалял лишние пустые строки? Мне нужно чтобы в столбце А положение заполненных ячеек не менялось.
Сделал без объединения, просто сцепил все через пустую строку
Это гораздо быстрее работает)) (Есть таблица, где нужно обработать тысяч 20 строк, тогда это особо заметно). А как сделать так, чтобы он не удалял лишние пустые строки? Мне нужно чтобы в столбце А положение заполненных ячеек не менялось.drugojandrew
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]
Тогда так [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