asked on

Find Merged Cells in a Column then take action on the range of rows related to that merged cell

Back to VBA, haven't touched it in a few years.

I have a larger project in mind but one step at a time.

I basically need to find any merged cell across rows only. Then identify all the rows that are included in that merged cell.

To do this I just want to change the color for now to test the code.

What I have that isn't working:

Sub Find_Merged_Cells
Dim Row as Range
For each Row in Selection
If Row.Merged = True Then
Row.EntireRow.Interior.ColorIndex=6
End If
Next Row
End Sub
example.xlsx

Dooglave

ASKER

Sub Find_Merged_Cells
Dim cel as Range
For each cel in Selection
If cel.MergeCells = True Then
cel.EntireRow.Interior.ColorIndex=6
End If
Next cel
End Sub

Well that's highlighting non merged cells that are in the same row as a merged cell in column A when I hightlight a few cells in column A. So It kinda works. But I want to figure out how to take action on each row that is part of a merged cell.

It's 99% there :|

Dooglave

ASKER

somehow I need to get the value of the "Range" of rows included in the merged cell.

Dooglave

ASKER

I think I figured it out: "MergeArea"

Sub Find_Merged_Cells
Dim cel as Range
For each cel in Selection
If cel.MergeCells = True Then
cel.MergeArea.EntireRow.Interior.ColorIndex=6
End If
Next cel
End Sub

Dooglave

ASKER

Next step Combine these three, So I find all merged cells, clean up that row by merging the cells in that MergedArea that are not merged, then un-merging them all so each record is on a single row with no merges...

Sub Find_Merged_Cells()
Dim cel As Range
For Each cel In Selection
If cel.MergeCells = True Then
cel.MergeArea.EntireRow.Interior.ColorIndex = 6
End If
Next cel
End Sub

Sub Merge_Cells()
cel As Range
Selection.MergeCells = False
For Each cel In Selection
txt = txt & cel.Value & Chr(10)
Next cel
Selection.Cells(1, 1).Value = txt
Selection.Cells(1, 1).Value = Trim(Selection.Cells(1, 1).Value)
Application.DisplayAlerts = False
Selection.Merge
Application.DisplayAlerts = True
End Sub

Sub UnMerge_Selection_Delete_Empty_Rows()
Row As Variant
Selection.MergeCells = False
For Row = 1 To Selection.Rows.Count
If Application.CountA(Selection.Rows(Row)) = 0 Then Selection.Rows(Row).Delete
Next Row
End Sub

Dooglave

ASKER

Help...... Thought process in this comboing:

Sub Find_Merged_Cells()
Dim cel, colcel, rowcel As Range
Dim txt As String
For Each cel In Selection
If cel.MergeCells = True Then
'cel.MergeArea.EntireRow.Interior.ColorIndex = 6
For Each colcel In cel.MergeArea.
If colcel.MergeCells = False Then
For Each rowcel In cel.MergeArea '(!!! I need to know the Row Range of the cel.MergeArea and use it with colcel that won't have a merged area cause it's not Merged.)
txt = txt & rowcel.Value & Chr(10)
Next rowcel
colcel.Value = Trim(txt)
' Then on to UnMerge_Selection_Delete_Empty_Rows()
End If
Next colcel
End If
Next cel
End Sub

Dooglave

ASKER

Stuck on this line: "For Each colcel In cel.MergeArea.EntireRow" I don't think it's looking at the range.

Sub Find_Merged_Cells()
Dim cel, colcel, rowcel, startCel, endCell As Range
Dim startRow, endRow, startColumn, endColumn As Variant
Dim txt As String
For Each cel In Selection
If cel.MergeCells = True Then
MsgBox "Found MergeCells True"
For Each colcel In cel.MergeArea.EntireRow
MsgBox "Looking for not merged in cel.MergeArea.EntireRow"
If colcel.MergeCells = False Then
MsgBox "Found colcel.MergeCells = False"
startRow = colcel.Row
endRow = startRow + cel.MergeArea.Rows.Count - 1
startColumn = colcel.Column
endColumn = startColumn + cel.MergedArea.Columns.Count - 1
Set startCell = Cells(startRow, startColumn)
Set endCell = Cells(endRow, endColumn)
MsgBox "startCell is " & startCell.Address
MsgBox "endCell is " & endCell.Address
For Each rowcel In Range(startCell, endCell)
txt = txt & rowcel.Value & Chr(10)
Next rowcel
colcel.Value = txt
colcel.Value = Trim(colcel.Value)
Application.DisplayAlerts = False
Range(startCell, endCell).Merge
Application.DisplayAlerts = True
End If
Next colcel
End If
Next cel
End Sub

Dooglave

ASKER

So anyone looking, that you don't waste your time. I got most of it working.
Working on this line now; "If Application.CountA(Rows(Row)) = 0 Then Rows(Row).Delete"

Sub Find_Merged_Cells()

Dim cel, colcel, rowcel As Range
Dim startCell, endCell As Range
Dim startEntireCell, endEntireCell As Range
Dim startEntireRow, endEntireRow, startEntireColumn, endEntireColumn As Variant
Dim startRow, endRow, startColumn, endColumn As Variant
Dim txt As String
Dim Row As Variant

For Each cel In Selection
If cel.MergeCells = True Then
startEntireRow = cel.Row
endEntireRow = startEntireRow + cel.MergeArea.Rows.Count - 1
startEntireColumn = 1
endEntireColumn = ActiveSheet.UsedRange.Columns.Count
Set startEntireCell = Cells(startEntireRow, startEntireColumn)
Set endEntireCell = Cells(endEntireRow, endEntireColumn)
MsgBox "startEntireCell is " & startEntireCell.Address
MsgBox "endEntireCell is " & endEntireCell.Address
For Each colcel In Range(startEntireCell, endEntireCell)
'MsgBox "Looking for not merged in Range(startEntireCell, endEntireCell"
If colcel.MergeCells = False Then
MsgBox "Found colcel.MergeCells = False"
startRow = colcel.Row
endRow = startRow + cel.MergeArea.Rows.Count - 1
startColumn = colcel.Column
endColumn = colcel.Column
Set startCell = Cells(startRow, startColumn)
Set endCell = Cells(endRow, endColumn)
MsgBox "startCell is " & startCell.Address
MsgBox "endCell is " & endCell.Address
For Each rowcel In Range(startCell, endCell)
txt = txt & rowcel.Value & Chr(10)
Next rowcel
colcel.Value = txt
colcel.Value = Trim(colcel.Value)
Application.DisplayAlerts = False
Range(startCell, endCell).Merge
Application.DisplayAlerts = True
Selection.MergeCells = False
For Each Row In Range(startCell, endCell)
If Application.CountA(Rows(Row)) = 0 Then Rows(Row).Delete
Next Row
End If
Next colcel
End If
Next cel
End Sub

Dooglave

ASKER

Ok, just about done.... Where are you guys?

Working on this, "txt = txt & rowcel.Value & Chr(10)"
It creates an extra CRLF, need to trim it :)

Hopefully it didn't mangle my data, will check in a bit.

Sub Find_Merged_Cells_and_Clean()

Dim xSelection As Range
Dim cel, colcel, rowcel, celrow As Range
Dim startCell, endCell As Range
Dim startEntireCell, endEntireCell As Range
Dim startEntireRow, endEntireRow, startEntireColumn, endEntireColumn As Variant
Dim startRow, endRow, startColumn, endColumn As Variant
Dim txt As String
Dim Row As Variant
'Set xSelection = ActiveSheet.UsedRange

For Each cel In ActiveSheet.UsedRange
If cel.MergeCells = True Then
startEntireRow = cel.Row
endEntireRow = startEntireRow + cel.MergeArea.Rows.Count - 1
startEntireColumn = 1
endEntireColumn = ActiveSheet.UsedRange.Columns.Count
Set startEntireCell = Cells(startEntireRow, startEntireColumn)
Set endEntireCell = Cells(endEntireRow, endEntireColumn)
'MsgBox "startEntireCell is " & startEntireCell.Address
'MsgBox "endEntireCell is " & endEntireCell.Address
For Each colcel In Range(startEntireCell, endEntireCell)
'MsgBox "Looking for not merged in Range(startEntireCell, endEntireCell"
If colcel.MergeCells = False Then
'MsgBox "Found colcel.MergeCells = False"
startRow = colcel.Row
endRow = startRow + cel.MergeArea.Rows.Count - 1
startColumn = colcel.Column
endColumn = colcel.Column
Set startCell = Cells(startRow, startColumn)
Set endCell = Cells(endRow, endColumn)
'MsgBox "startCell is " & startCell.Address
'MsgBox "endCell is " & endCell.Address
txt = ""
For Each rowcel In Range(startCell, endCell)
txt = txt & rowcel.Value & Chr(10)
Next rowcel
startCell.Value = txt
startCell.Value = Trim(colcel.Value)
Application.DisplayAlerts = False
Range(startCell, endCell).Merge
Application.DisplayAlerts = True
End If
Next colcel
Range(startEntireCell, endEntireCell).MergeCells = False
For Each celrow In Range(startEntireCell, endEntireCell)
'MsgBox "The Row is " & celrow.Row
If Application.CountA(Rows(celrow.Row)) = 0 Then Rows(celrow.Row).Delete
Next celrow
End If
Next cel
End Sub

Dooglave

ASKER

Done for now. names of Variables are kinda goofy, will clean it up later. But this is solid working code for those of you looking for the same thing. I'm sure there is a short cut to some of this stuff but I couldn't figure out how to do it any other way.

Sub Find_Merged_Cells_and_Clean()

    Dim xSelection As Range
    Dim cel, colcel, rowcel, celrow As Range
    Dim startCell, endCell As Range
    Dim startEntireCell, endEntireCell As Range
    Dim startEntireRow, endEntireRow, startEntireColumn, endEntireColumn As Variant
    Dim startRow, endRow, startColumn, endColumn As Variant
    Dim txt As String
    Dim Row As Variant
    Dim Rule As Range
    Dim RuleRange As Variant
    Dim rng() As String
    
    'Set xSelection = ActiveSheet.UsedRange
    
    For Each cel In ActiveSheet.UsedRange
     If cel.MergeCells = True Then
      'cel.MergeArea.EntireRow.Interior.ColorIndex = 6
      startEntireRow = cel.Row
      endEntireRow = startEntireRow + cel.MergeArea.Rows.Count - 1
      startEntireColumn = 1
      endEntireColumn = ActiveSheet.UsedRange.Columns.Count
      Set startEntireCell = Cells(startEntireRow, startEntireColumn)
      Set endEntireCell = Cells(endEntireRow, endEntireColumn)
      'MsgBox "startEntireCell is " & startEntireCell.Address
      'MsgBox "endEntireCell is " & endEntireCell.Address
       For Each colcel In Range(startEntireCell, endEntireCell)
        'MsgBox "Looking for not merged in Range(startEntireCell, endEntireCell"
        If colcel.MergeCells = False Then
         'MsgBox "Found colcel.MergeCells = False"
         startRow = colcel.Row
         endRow = startRow + cel.MergeArea.Rows.Count - 1
         startColumn = colcel.Column
         endColumn = colcel.Column
         Set startCell = Cells(startRow, startColumn)
         Set endCell = Cells(endRow, endColumn)
         'MsgBox "startCell is " & startCell.Address
         'MsgBox "endCell is " & endCell.Address
         txt = ""
          For Each rowcel In Range(startCell, endCell)
           If rowcel <> endCell Then
           txt = txt & rowcel.Value & Chr(10)
           Else
            txt = txt & rowcel.Value
           End If
          Next rowcel
         startCell.Value = txt
         startCell.Value = Trim(colcel.Value)
         Application.DisplayAlerts = False
         Range(startCell, endCell).Merge
         Application.DisplayAlerts = True
        End If
       Next colcel
       Range(startEntireCell, endEntireCell).MergeCells = False
       For Each celrow In Range(startEntireCell, endEntireCell)
       'MsgBox "The Row is " & celrow.Row
        If Application.CountA(Rows(celrow.Row)) = 0 Then Rows(celrow.Row).Delete
       Next celrow
     End If
    Next cel
   Cells(1, 1).EntireColumn.Insert Shift:=xlToRight
    For Each Rule In Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2))
     If InStr(Rule.Value, "Disabled") Then
      Cells(Rule.Row, 1).Value = "Disabled"
      rng = Split(Rule.Value, Chr(10))
      If UBound(rng) < 1 Then
      Else
       rng(1) = ""
       Rule.Value = rng(0)
      End If
     End If
    Next Rule
   'Columns("A:A").EntireColumn.AutoFit
    ActiveSheet.Columns.AutoFit
    ActiveSheet.Rows.AutoFit
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Saqib Husain

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SOLUTION

Rob Brockett

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial