Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
макрос объединения ячеек с последующей их нумерацией автоматической
 
#1
04.03.2020 16:23:29
Доброго  дня! Подскажите пожалуйста макрос объединения ячеек с последующей их нумерацией автоматической.

Есть в ячейке выпадающий список с числами. При выборе нужного значения в столбце должно происходить объединение ячеек на длину всего столбца на количество ячеек, выбранных в выпадающем списке.
И автоматически пронумероваться.
 
 
 
#2
04.03.2020 16:44:54
Цитата
Подскажите пожалуйста макрос объединения ячеек
  Макрос в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("B1")) Is Nothing Then
   Application.EnableEvents = False
Dim i As Long
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim n As Integer
  Range("B3:B" & iLastRow).UnMerge
  Range("B3:B" & iLastRow).ClearContents
    n = 1
  For i = 3 To iLastRow Step Target
    Range("B" & i & ":B" & i + Target - 1).Merge
    Range("B" & i & ":B" & i + Target - 1).BorderAround Weight:=xlThin
    Range("B" & i) = n
    n = n + 1
  Next
 End If
   Application.EnableEvents = True
End Sub
 
 
 
#3
04.03.2020 16:45:31
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Row = 1 Then
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    myMerge Target.Column, Target.Value
                End If
            End If
        End If
    End If
End Sub
'
Sub myMerge(x As Integer, n As Long)
    Dim y As Long
    Dim m As Long
    Dim i As Long
    Dim b As Variant
    With ActiveSheet
    Application.EnableEvents = False
        m = Cells(Rows.Count, x).End(xlUp).Row
        .Columns(x).MergeCells = False
        .Range(.Cells(3, x), .Cells(m, x)).Clear
        
        For y = 3 To m Step n
            i = i + 1
            With .Cells(y, x)
                .Value = i
                With .Resize(n)
                    .MergeCells = True
                    For Each b In Array(xlEdgeLeft, xlEdgeTop, xlEdgeRight, xlEdgeBottom, xlInsideVertical, xlInsideHorizontal)
                        With .Borders(b)
                            .LineStyle = xlContinuous
                            .ColorIndex = 0
                            .TintAndShade = 0
                            .Weight = xlThin
                        End With
                    Next
                End With
            End With
        Next
    Application.EnableEvents = True
    End With
End Sub
 
 
 
#4
05.03.2020 00:31:57
Ребята, оба решения работают отлично. А как можно сделать перерисовку незаметной? Чтобы обновление происходило пошустрее
 
 
 
#5
05.03.2020 09:30:40
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Row = 1 Then
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    myMerge Target.Column, Target.Value
                End If
            End If
        End If
    End If
End Sub
'
Sub myMerge(x As Integer, n As Long)
    Dim y As Long
    Dim m As Long
    Dim i As Long
    Dim b As Variant
    With ActiveSheet
    Application.EnableEvents = False
    Application.ScreenUpdating = False
        m = Cells(Rows.Count, x).End(xlUp).Row
        .Columns(x).MergeCells = False
        .Range(.Cells(3, x), .Cells(m, x)).Clear
        Dim a As Variant
        ReDim a(1 To m - 2, 1 To 1)
        For y = 3 To m Step n
            i = i + 1
            With .Cells(y, x)
                a(y - 2, 1) = i
                With .Resize(n)
                    .MergeCells = True
                End With
            End With
        Next
        With .Cells(3, x).Resize(UBound(a, 1))
            .Cells = a
            For Each b In Array(xlEdgeLeft, xlEdgeTop, xlEdgeRight, xlEdgeBottom, xlInsideVertical, xlInsideHorizontal)
                With .Borders(b)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
            Next
        End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    End With
End Sub
Так должно быть чуть быстрее.
 
 
 
#6
05.03.2020 11:49:27
МатросНаЗебре, отлично работает =) а как можно выравнивание сделать по горизонтали и вертикали?
 
 
 
#7
05.03.2020 11:59:59
Цитата
Medvedoc написал:
а как можно выравнивание сделать по горизонтали и вертикали?
Тут принято, одна тема - один решаемый вопрос. Лучше создать другую тему.
 
 
 
#8
05.03.2020 12:45:16
МатросНаЗебре, странно. Попробовал добавить возможность выравнивания перестал работать макрос. Попробовал создать новую книгу и добавить по новой макрос, все равно без изменений.

Приложил файл с обойими примерами. Может я что-то нечайно отключил?
Изменено: Medvedoc - 05.03.2020 12:56:17
 
 
 
#9
12.03.2020 12:52:29
МатросНаЗебре, Kuzmich, решил вопрос свой со стилями ячейки =) но появился другой вопрос. Можно как-то приделать прогрессбар выполнения макроса? Чтобы было понятно пользователю, что происходит процесс объединения ячеек. Чтобы исключить момент восприятие пользователем текущего процесса как зависанием excel?
 
 
 
#10
12.03.2020 13:07:15
Код
        For y = 3 To m Step n
            Application.StatusBar = Format(y / m, "0%")
            i = i + 1
            With .Cells(y, x)
                a(y - 2, 1) = i
                With .Resize(n)
                    .MergeCells = True
                End With
            End With
        Next
        Application.StatusBar = False
Как вариант, можно писать в строку состояния.
 
 
 
#11
12.03.2020 20:31:22
МатросНаЗебре, а каким образом можно привязать к основному макросу?
 
 
 
#12
12.03.2020 20:35:55
Цитата
каким образом можно привязать к основному макросу?
Замените этот цикл в коде из сообщения #5
 
 
 
#13
12.03.2020 20:41:40
Kuzmich, а понял ) все работает отлично. Спасибо огромное
А именно в ячейке можно как-то вывести прогрессбар при выполнении данного макроса?
 
 
 
#14
12.03.2020 20:52:28
Medvedoc,
Почитайте здесь https://www.excel-vba.ru/chto-umeet-excel/otobrazit-process-vypolneniya/
 
 
 
#15
12.03.2020 21:10:26
Kuzmich, отличный мануал ) получилось сделать. Спасибо!!!
 
 
 
#16
12.03.2020 21:25:41
Kuzmich, https://wellsr.com/vba/2017/excel/vba-application-statusbar-to-mark-progress/ вот отсюда дополнил тем, что было необходимо
 
 
 
#17
29.11.2020 08:45:28
МатросНаЗебре, Kuzmich, странно, но оба макроса в Office 2013 совсем не работают.
 
 
 
#18
29.11.2020 17:31:21
Цитата
но оба макроса в Office 2013 совсем не работают.
У меня нет 2013 и проверить не могу.
А точно макросы в модуле листа?
Возможно отключены события листа.
Включите
Код
Application.DisplayAlerts = True
 
 
 
Страницы: 1
Наверх