Я хотел бы автоматизировать объединение ячеек по столбцам для нескольких столбцов на основе информации в определенном столбце.

Основываясь на исходном изображении, значение стека будет определять номер. строк для объединения столбцов Color, Stack и Size, как показано на снимке экрана Outcome.

Я нашел этот код ниже, но не знаю, как адаптировать его к моим требованиям. (Я новичок в коде и учусь)

Dim srw As Long, frw As Variant
With Worksheets("Sheet1")
    With Intersect(.Columns(3), .UsedRange)
        srw = 0
        Do While srw < .Rows.Count
            frw = .Cells(srw + 1, 1).Value
            If Not IsError(frw) Then
                .Cells(srw + 1, 1).Resize(frw, 1).Offset(0, -1).Merge
                srw = srw + frw
            Else
                srw = .Cells(Rows.Count, 1).End(xlUp).Row
            End If
        Loop
    End With
End With

Начальное значение:
Initial

Итог :
Outcome

2
Russ Sidney 24 Окт 2018 в 09:33

2 ответа

Лучший ответ

Попробуйте этот код

Sub Test()
Dim x, r As Long, c As Long

Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            x = .Cells(r, 3).Value
            If IsNumeric(x) And x > 1 Then
                For c = 2 To 4
                    .Cells(r, c).Resize(x).Merge
                Next c
            End If
        Next r
    End With
Application.ScreenUpdating = True
End Sub
3
YasserKhalil 24 Окт 2018 в 07:03

При необходимости измените имя листа и диапазон и попробуйте:

Option Explicit

Sub Test()

    Dim LastRow As Long
    Dim i As Long
    Dim Number_Of_Rows As Long
    Dim wsTest As Worksheet

    With wsTest
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LastRow
            If .Range("C" & i).Value > 1 Then
                Number_Of_Rows = .Range("C" & i).Value
                With .Range("B" & .Range("C" & i).Row & ":B" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
                With .Range("C" & .Range("C" & i).Row & ":C" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
                With .Range("D" & .Range("C" & i).Row & ":D" & .Range("C" & i).Row + (Number_Of_Rows - 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            ElseIf .Range("C" & i).Value <> "" Then
                With .Range("B" & i & ":D" & i)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
            End If
        Next i
    End With

End Sub
1
Error 1004 24 Окт 2018 в 07:38
52962343