/ / VBA Excel Злиття клітин на основі специфічного значення клітинки - excel-vba, vba, excel

VBA Excel Злиття клітин на основі специфічного значення клітинки - excel-vba, vba, excel

Я хотів би автоматизувати злиття комірок на стовпці для декількох стовпців на основі інформації в певному стовпці.

На підставі малюнка нижче значення в стовпці cбуде визначати кількість рядків, які необхідно об'єднати для стовпців A до K. З кожною зміною значення в колонці C - злиття буде починатися знову.

введіть опис зображення тут

Private Sub MergeCells_C()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("C1:C1000") "Set the range limits here

MergeAgain:

For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Відповіді:

0 для відповіді № 1

Це працювало для мене:

Sub MergeCellsByC()

Dim c As Range, sht As Worksheet, currV
Dim n As Long, rw As Range, r As Range

Set sht = ActiveSheet
Set c = sht.Range("C4") "adjust to suit....
currV = Chr(0)          "start with a dummy value

Do
If c.Value <> currV Then
If n > 1 Then
Set rw = c.EntireRow.Range("A1:K1") "A1:K1 relative to the row we"re on...
Application.DisplayAlerts = False
"loop across the row and merge the cells above
For Each r In rw.Cells
r.Offset(-n).Resize(n).Merge
Next r
Application.DisplayAlerts = True
End If
currV = c.Value
n = 1
Else
n = n + 1 "increment count for this value
End If

If Len(c.Value) = 0 Then Exit Do "exit on first empty cell
Set c = c.Offset(1, 0) "next row down
Loop

End Sub