Sub DeleteEmptyRows()
LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count 'определяем размеры таблицы
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1 'проходим от последней строки до первой
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete 'если в строке пусто - удаляем ее
Next r
End Sub
2. Снятие объединения ячеек и заполнение каждой из них
Код
Sub UnMerge_and_Fill_by_HyperLink()
'---------------------------------------------------------------------------------------
' Procedure : UnMerge_and_Fill_by_HyperLink
' Author : The_Prist ( http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpa... )
' Date : 23.12.2009
' Purpose : Снимает объединение со всех ячеек выделенного диапазона _
и заполняет все разгруппированные ячейки каждой бывшей группы ссылками на значения верхней левой
'---------------------------------------------------------------------------------------
Dim sAddress As String
Dim rRange As Range, rCell As Range, rEmptyRange As Range
Dim lLastRow As Long, lLastCol As Long
lLastRow = Cells.SpecialCells(xlLastCell).Row
lLastCol = Selection.Column + Selection.Columns.Count - 1
If lLastRow > Selection.Row + Selection.Rows.Count - 1 Then lLastRow = Selection.Row + Selection.Rows.Count - 1
Application.ScreenUpdating = False
Set rRange = Range(Cells(Selection.Row, Selection.Column), Cells(lLastRow, lLastCol))
For Each rCell In rRange
If rCell.MergeCells = True Then
sAddress = rCell.MergeArea.Address: rCell.UnMerge
On Error Resume Next: Set rEmptyRange = Range(sAddress).SpecialCells(xlCellTypeBlanks)
If Not rEmptyRange Is Nothing Then rEmptyRange.Formula = "=" & rCell.Cells(1).Address
End If
Next
Set rRange = Nothing: Set rCell = Nothing: Set rEmptyRange = Nothing
Application.ScreenUpdating = True
End Sub
3. Разделение ячеек по строкам
Код
Sub ins()
Dim rng As Range, sh As Worksheet
Set sh = ActiveSheet
lr = Cells(Rows.Count, 1).End(xlUp).Row
Worksheets.Add
sh.Range("A1:L2").Copy Destination:=Range("A1")
t = 3
For i = 3 To lr
arr = Split(sh.Cells(i, 5).Value, "/")
For j = 0 To UBound(arr)
sh.Range("A" & i & ":L" & i).Copy Destination:=Range("A" & t)
Range("E" & t).Value = arr(j)
t = t + 1
Next
End Sub
Необходимо объединить это в один макрос и чтобы действия выполнялись в такой последовательности, как написано выше.
Есть проблема: Первый код работает со всем листом Второй код работает только с выделенными ячейками Третий - в конкретным диапазоном("A1:L2"), а далее по тексту со столбцами А и Е
В случае совмещения в один все это может сработать не совсем корректно. Можете проверить результат, создав еще один макрос и запустив:
Код
Sub RunAll()
call DeleteEmptyRows
call UnMerge_and_Fill_by_HyperLink
call ins
End sub
P.S. Для оформления кодов используйте кнопку <...>
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
sdens2009, можно обойтись без автозаполнения объединённых
Алгоритм полуавтоматического преобразования исходных данных в конечный результат (в скобках - для вашего случая): 1. Ваша рабочая область не включает первые 2 строки - их не трогаем. Далее работаем только в рабочей области (A3:L9) 2. Снимаем кнопкой объединение ячеек в рабочей области. 3. Выделяем столбец "A" - можно целиком. Жмём F5 —> Выделить —> Пустые ячейки. Раскрываем на ленте во вкладке "Главная" в группе "Ячейки" инструмент "Удалить", выбираем "Удалить строки с листа" — можно эту кнопку на панель просто добавить, чтобы не мучиться. Пустые строки удалены. 4. Выделяем диапазон ячеек для разбивки по разделителю (E3:E8). Запускаем макрос отсюда. Ячейки разбиты вниз по разделителю. 5. Выделяем получившийся диапазон (A3:L19). Запускаем этот макрос. Пустые заполнены значениями верхних. Profit!
Думаю ,что полуавтоматический вариант вам подойдёт больше, т.к. вы хоть будете понимать, что делаете. А так, условия у вас чуть поменяются и статичные коды под ваш пример могут не сработать…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Sub test()
Dim arr(), i&, j&, itxt$, iarr(), lrow&, larr$(), x&, ikey
With ActiveSheet lrow = .Range("a" & .Rows.Count).End(xlUp).Row
arr = .Range(.[a3], .Cells(lrow, "l")).Value
ReDim iarr(1 To UBound(arr, 2), 1 To 1)
For i = 1 To UBound(arr)
If Not IsEmpty(arr(i, 1)) Then
If Not IsEmpty(arr(i, 2)) Then itxt = arr(i, 2)
larr = Split(Trim(arr(i, 5)), "/")
ReDim Preserve iarr(1 To UBound(arr, 2), 1 To UBound(iarr, 2) + UBound(larr) + 1)
For Each ikey In larr
x = x + 1
For j = 3 To UBound(arr, 2)
iarr(j, x) = arr(i, j)
Next j
iarr(1, x) = x: iarr(2, x) = itxt: iarr(5, x) = ikey
Next ikey
End If
Next i
.Range(.Rows(3), .Rows(lrow)).Delete
.Range("a3").Resize(x, UBound(iarr)).Value = Application.Transpose(iarr)
End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
sdens2009 написал: Sanja , у меня первая строка...
Мой код написан для того примера, который Вы привели в 5-м сообщении. Что и где там 'у Вас' мне неведомо... Макрос в файле из сообщения 6 корректно работает?
Согласие есть продукт при полном непротивлении сторон
sdens2009, я как в воду глядел))) посмотрите комментарии помогающих Если вы меняете структуру, то как вы можете думать, что рабочие на конкретном примере варианты будут работать при любых изменениях?!…
Чтобы получить универсальный макрос, нужно и просьбу формулировать соответственно
Однако, не так уж много шансов, что кто-то будет делать "готовое" универсальное решение за интерес. Возможно, ветка Работа вам приглянётся
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄