Merge Cells Logic

[Brian B]

Hello,
I would like to be able to go RowXRow/Column and merge Cells vertically
based on the conditions that the first cell has text content, and the
subsequent cells do not.

This selection would progress downward/column until another cell that
contains Text was encountered, and then the gathered selection previous to
that 2nd cell with text was encountered, would be merged.

I'm thinking I should use a Boolean to = True when cells contain content,
and False when they do not, and Select cells based around that toggle.

Obviously this logic is a bit tricky for me to handle, so any help is
appreciated.

Thanks,
Brian

 

[Jacob Skaria]

Brian

Try the below macro..with your data in ColA. It should merge and writ the
data in ColB. Separator used is space. change if needed to suit your
requirement..

Sub Macro()
Dim lngRow As Long, lngNRow As Long, strData As String
For lngRow = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.IsText(Range("A" & lngRow)) Then
If Trim(strData) <> "" Then _
lngNRow = lngNRow + 1: Range("B" & lngNRow) = Trim(strData)
strData = Range("A" & lngRow)
Else
strData = strData & " " & Range("A" & lngRow)
End If
Next
Range("B" & lngNRow + 1) = Trim(strData)
End Sub

If this post helps click Yes

 

[Rick Rothstein]

Give the following macro a try. You can set the columns to be search in the
ColumnRange constant (Const) statement. In my example code, I set the merges
to take place in Columns A, B, C and E. I also started the merge after Row 2
(which is set in the StartRowForMerges constant).

Sub MergeColumnsOfBlanks()
Dim Cols() As String
Dim X As Long, LastRow As Long
Dim BlankCells As Range, BlankRange As Range
Const ColumnRange As String = "A,B,C,E"
Const StartRowForMerges As Long = 2
Cols = Split(ColumnRange, ",")
On Error Resume Next
Application.ScreenUpdating = False
For X = 0 To UBound(Cols)
LastRow = Cells(Rows.Count, Cols(X)).End(xlUp).Row
Set BlankCells = Columns(Cols(X)).SpecialCells(xlCellTypeBlanks)
For Each BlankRange In BlankCells
If BlankRange.Row > StartRowForMerges And _
BlankRange.Row < LastRow + 1 Then
BlankRange.Offset(-1).Resize(BlankRange.Rows.Count + 1).Merge
End If
Next
Next
Application.ScreenUpdating = True
End Sub

 

[Jacob Skaria]

Hi; intially i though to merge th data. The below will merge the cells

Sub Macro()
Dim lngRow As Long, lngSRow As Long
For lngRow = 1 To Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.IsText(Range("A" & lngRow)) Then
If lngSRow <> 0 Then
Range("A" & lngSRow & ":A" & lngRow - 1).Cells.Merge
End If
lngSRow = lngRow
End If
Next
Range("A" & lngSRow & ":A" & lngRow).Cells.Merge
End Sub

If this post helps click Yes

 

[Brian B]

Thanks very much Jacob, for the help.

What I'd like to do is take the code you've provided and make it work for a
User Selectable number of Columns. I haven't had much luck with it, which
means I don't understand the logic/syntax of what you wrote sufficiently.

Here's my edit to the code that doesn't compile: (notice it includes Two
examples of translating the # of Columns to a Column Header letter).

Dim inputColumn As Integer

inputColumn = InputBox("How many levels of requirements did this report
account for?", "Requirement Levels")
inputColumn = inputColumn * 2
' Hide the Columns between Originating and End Leaf
Dim ColMod As Integer
Dim MyColNum As Integer
Dim intInt As Integer
Dim ConvertCol As Variant
Dim currentColumn As Integer

MyColNum = inputColumn
'Translate Column header to usable letter as ConvertCol

ColMod = MyColNum Mod 26 'div column # by 26. Remainder is
the_Second letter
If ColMod = 0 Then 'if no remainder then fix value
ColMod = 26
MyColNum = MyColNum - 26
End If
intInt = MyColNum \ 26 'first letter
If intInt = 0 Then ConvertCol = Chr(ColMod + 64) Else _
ConvertCol = Chr(intInt + 64) & Chr(ColMod + 64)

Dim lngRow As Long, lngSRow As Long

For ColumnCount = 1 To inputColumn
currentColumn = ColumnCount
'Figure out the Letter for the Column
Dim ColMod2 As Integer
Dim MyColNum2 As Integer
Dim intInt2 As Integer
Dim ConvertCol2 As Variant
Dim currentColumn2 As Integer
RowMax = ActiveSheet.UsedRange.Rows.Count

MyColNum2 = currentColumn

ColMod2 = MyColNum2 Mod 26 'div column # by 26. Remainder is
the_Second letter
If ColMod2 = 0 Then 'if no remainder then fix value
ColMod2 = 26
MyColNum2 = MyColNum2 - 26
End If
intInt2 = MyColNum2 \ 26 'first letter
If intInt2 = 0 Then ConvertCol2 = Chr(ColMod2 + 64) Else _
ConvertCol2 = Chr(intInt2 + 64) & Chr(ColMod2 + 64)


For lngRow = 1 To RowMax = ActiveSheet.UsedRange.Rows.Count
If WorksheetFunction.IsText(Range(ConvertCol2 & lngRow)) Then
If lngSRow <> 0 Then
Range(ConvertCol2 & lngSRow & ":" & ConvertCol2 & lngRow - 1).Cells.Merge
End If
lngSRow = lngRow
End If
Next
Range(ConvertCol2 & lngSRow & ":" & ConvertCol2 & lngRow).Cells.Merge
Next ColumnCount

End Sub

 

[Brian B]

Thanks for your help Rick.

In the below I've tried to modify your code to allow for a User Input as far
as Which Columns are affected. Also, I've tried to make the amount of cell
merger consistent across the bottom row, i.e., if the spreadsheet's last row
is 1500, then all of the columns should "merge" down to row 1500...as opposed
to the current staggered merger from column to column.

However, the following code doesn't work, so I was wondering if you had any
input to assist.

Thanks,
Brian

Code:
Sub MergeColumnsOfBlanks()

Dim Cols() As String
Dim X As Long, LastRow As Long
Dim BlankCells As Range, BlankRange As Range
Dim ColumnCount As Integer
Dim currentColumn As Integer

Const ColumnRange As String = "A,B,C,D,E,F,G,H"
Const StartRowForMerges As Long = 2
ColumnCount = InputBox("How many levels of Requirements did the Compliance
Matrix Account for?", "Requirement Levels")
ColumnCount = ColumnCount * 2

Cols = Split(ColumnRange, ",")
On Error Resume Next
Application.ScreenUpdating = False
For X = 0 To ColumnCount
currentColumn = ColumnCount
MyColNum = currentColumn

'Translate Column header to usable letter as ConvertCol
ColMod = MyColNum Mod 26 'div column # by 26. Remainder is the_Second
letter
If ColMod = 0 Then 'if no remainder then fix value
ColMod = 26
MyColNum = MyColNum - 26
End If
intInt = MyColNum \ 26 'first letter
If intInt = 0 Then ConvertCol = Chr(ColMod + 64) Else _
ConvertCol = Chr(intInt + 64) & Chr(ColMod + 64)
' Here's where I tried to extend the merge to the bottom-most used row
LastRow = Cells(ActiveSheet.UsedRange.Rows.Count, Cols(X)).End(xlUp).row
Set BlankCells = Columns(ConvertCol(X)).SpecialCells(xlCellTypeBlanks)
For Each BlankRange In BlankCells
If BlankRange.row > StartRowForMerges And _
BlankRange.row < LastRow + 1 Then
BlankRange.Offset(-1).Resize(BlankRange.Rows.Count + 1).Merge
End If
Next
Next
Application.ScreenUpdating = True
End Sub