Последние записи

made in programmersforum 6

Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk

Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw

30th
Окт

Правильно объединить ячейки построчно в Microsoft Office Excel

Posted by obzor under VBA

Имеется счет позиций много больше 1000 , при переносе данных образуются ячейки которых необходимо объединить. Пример прикреплен как есть и как должно быть. Помогите найти решение макросом.

Вложения

для решения.xlsx (24.9 Кб)

Elixi

Код:

Sub Irek11()
'   Irek11, для вашего файла, если его исправлять после переноса данных, можно например так

    Dim Rw&, RwF&, RwL&
    
    ActiveSheet.Copy After:=Sheets(ActiveSheet.Index)
    RwF = 20: RwL = Cells(Rows.Count, "D").End(xlUp).Row
    
Application.ScreenUpdating = False
    For Rw = RwF To RwL
        With Range("D" & Rw & ":T" & Rw & _
                    ",U" & Rw & ":W" & Rw & _
                    ",X" & Rw & ":Y" & Rw & _
                    ",Z" & Rw & ":AC" & Rw & _
                    ",AD" & Rw & ":AG" & Rw)
            .MergeCells = True
             With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End With
        With Range("AD" & Rw & ":AG" & Rw)
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        End With
        With Cells(Rw, "Z")
            .Value = Replace(.Value, "'", "")
            .Value = Replace(.Value, ".", ",")
            .NumberFormat = "#,##0.00"
        End With
        With Cells(Rw, "AD")
            .Value = Replace(.Value, "'", "")
            .Value = Replace(.Value, ".", ",")
            .NumberFormat = "#,##0.00"
        End With
    Next
Application.ScreenUpdating = True
End Sub