Страницы: 1
RSS
Выполнение трех макросов последовательно.
 
Имеются 3 макроса:
1. Удаление пустых строк
Код
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

Необходимо объединить это в один макрос и чтобы действия выполнялись в такой последовательности, как написано выше.  
Изменено: sdens2009 - 03.04.2018 13:14:04
 
Есть проблема:
Первый код работает со всем листом
Второй код работает только с выделенными ячейками
Третий - в конкретным диапазоном("A1:L2"), а далее по тексту со столбцами А и Е

В случае совмещения в один все это может сработать не совсем корректно.
Можете проверить результат, создав еще один макрос и запустив:
Код
Sub RunAll()
call DeleteEmptyRows
call UnMerge_and_Fill_by_HyperLink
call ins
End sub
P.S. Для оформления кодов используйте кнопку <...>
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Может быть проще выложить файл и написать , как есть и как надо?
"Все гениальное просто, а все простое гениально!!!"
 
Сейчас скину файл
 
Тут исходный вариант, и тот который необходим в конце.
 
Ваши три макроса можно заменить одним. Красоту сами наведете
Код
Sub sdens2009()
With Worksheets("Лист1")
    arr = .Range("B3:L" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
    ReDim arrNew(1 To UBound(arr) * 4, 1 To 12)
    nRow = 1
    For I = 1 To UBound(arr)
        iStr = Split(arr(I, 4), "/")
        For N = 0 To UBound(iStr)
            arrNew(nRow, 1) = nRow
            If arr(I, 1) = Empty Then
                arrNew(nRow, 2) = arrNew(nRow - 1, 2)
            Else
                arrNew(nRow, 2) = arr(I, 1)
            End If
            arrNew(nRow, 3) = arr(I, 2)
            arrNew(nRow, 4) = arr(I, 3)
            arrNew(nRow, 5) = iStr(N)
            For J = 6 To 12
                arrNew(nRow, J) = arr(I, J - 1)
            Next
            nRow = nRow + 1
        Next
    Next
    Application.ScreenUpdating = False
    .Rows("3:" & UBound(arr) + 3).Delete
    .Range("A3").Resize(nRow - 1, 12) = arrNew
End With
Application.ScreenUpdating = True
End Sub
Изменено: Sanja - 03.04.2018 13:28:27
Согласие есть продукт при полном непротивлении сторон
 
sdens2009, можно обойтись без автозаполнения объединённых  ;)

Алгоритм полуавтоматического преобразования исходных данных в конечный результат (в скобках - для вашего случая):
1. Ваша рабочая область не включает первые 2 строки - их не трогаем. Далее работаем только в рабочей области (A3:L9)
2. Снимаем кнопкой объединение ячеек в рабочей области.
3. Выделяем столбец "A" - можно целиком. Жмём F5 —> Выделить —> Пустые ячейки. Раскрываем на ленте во вкладке "Главная" в группе "Ячейки" инструмент "Удалить", выбираем "Удалить строки с листа" — можно эту кнопку на панель просто добавить, чтобы не мучиться. Пустые строки удалены.
4. Выделяем диапазон ячеек для разбивки по разделителю (E3:E8). Запускаем макрос отсюда. Ячейки разбиты вниз по разделителю.
5. Выделяем получившийся диапазон (A3:L19). Запускаем этот макрос. Пустые заполнены значениями верхних.
Profit!  ;)

Думаю ,что полуавтоматический вариант вам подойдёт больше, т.к. вы хоть будете понимать, что делаете. А так, условия у вас чуть поменяются и статичные коды под ваш пример могут не сработать…
Изменено: Jack Famous - 03.04.2018 13:57:55
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Sanja, у меня первая строка после шапки некорректно отображается. Как это можно изменить?
Изменено: sdens2009 - 03.04.2018 14:13:52
 
Jack Famous, спасибо за совет. Буду знать :)  
 
Код
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
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, та же проблема, что на скрине выше
 
Если данные таблицы начинаются с 4 строки, то замените "a3" на "a4"
тут
Код
arr = .Range(.[a3], .Cells(lrow, "l")).Value

и тут
Код
.Range("a3").Resize(x, UBound(iarr)).Value = Application.Transpose(iarr)


Первая строка некорректно отображается после или до работы процедуры?
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,  начинается с 3-й строки. После того как применяю макрос такая ошибка
 
Да (случайно это обнаружил), и для UnMerge не обязательно проводить предварительную проверку.
 
Сорри. я не вникал в коды.
но может сделать так проще, чтобы вносить изменения в нужный макрос:
Код
Sub Step_by_step()

Call DeleteEmptyRows

Call UnMerge_and_Fill_by_HyperLink

Call ins

End Sub
Изменено: Sobes - 03.04.2018 21:35:27
 
Цитата
sdens2009 написал: Sanja , у меня первая строка...
Мой код написан для того примера, который Вы привели в 5-м сообщении. Что и где там 'у Вас' мне неведомо...
Макрос в файле из сообщения 6 корректно работает?
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sobes написал:
Сорри. я не вникал в коды.
почитайте сообщение №2 там все написано про данный способ.
"Все гениальное просто, а все простое гениально!!!"
 
Sobes, было уже )) См. #2
 
sdens2009, я как в воду глядел))) посмотрите комментарии помогающих
Если вы меняете структуру, то как вы можете думать, что рабочие на конкретном примере варианты будут работать при любых изменениях?!…

Чтобы получить универсальный макрос, нужно и просьбу формулировать соответственно  :excl:

Однако, не так уж много шансов, что кто-то будет делать "готовое" универсальное решение за интерес.
Возможно, ветка Работа вам приглянётся  ;)
Изменено: Jack Famous - 03.04.2018 22:26:15
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх