Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

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

Posted on 2013-11-15
11
429 Views
Last Modified: 2013-11-20
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
0
Comment
Question by:Dooglave
  • 9
11 Comments
 
LVL 6

Author Comment

by:Dooglave
ID: 39651682
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 :|
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39651688
somehow I need to get the value of the "Range" of rows included in the merged cell.
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39651712
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
0
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
LVL 6

Author Comment

by:Dooglave
ID: 39651725
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
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39651836
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
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39651994
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
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39652309
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
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39652468
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
0
 
LVL 6

Author Comment

by:Dooglave
ID: 39652648
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

0
 
LVL 43

Accepted Solution

by:
Saqib Husain, Syed earned 250 total points
ID: 39652929
I cannot thing of a shorter method but I have shortened the code.

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
    
                    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Sheet1.Copy , Sheet1
            startEntireColumn = 1
            endEntireColumn = ActiveSheet.UsedRange.Columns.Count
    For Each cel In ActiveSheet.UsedRange
        If cel.MergeCells = True Then
            lastrow = cel.Row + cel.MergeArea.Rows.Count - 1
            For Each colcel In cel.MergeArea.EntireRow.Resize(, endEntireColumn).Cells
                If colcel.MergeCells = False Then
                    txt = ""
                    For Each rowcel In Intersect(cel.MergeArea.EntireRow, colcel.EntireColumn)
                        txt = txt & rowcel.Value & IIf(rowcel.Row = lastrow, Chr(10), "")
                    Next rowcel
                    colcel.Value = Trim(txt)
                    Intersect(cel.MergeArea.EntireRow, colcel.EntireColumn).Merge
                End If
            Next colcel
            cel.EntireRow.MergeCells = False
            Range(cel.Offset(1), Cells(lastrow, 1)).EntireRow.Delete
        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
    ActiveSheet.Columns.AutoFit
    ActiveSheet.Rows.AutoFit
                    Application.DisplayAlerts = True
End Sub

Open in new window

0
 
LVL 10

Assisted Solution

by:broro183
broro183 earned 250 total points
ID: 39654517
hi,

I haven't looked at the method yet, but I have taken out the unused variables & added some With statements. My personal preference is to use With statements to identify groupings of actions on the same "object". This approach may or may not run faster due to the fact that the code doesn't need to fully resolve the reference every time an object is referred to.

How long does your code take to run?
I think it could be potentially be made faster with some changes to how the used range is defined but if you are happy with the current execution speed, the changes may not be worthwhile.

Option Explicit

Sub Find_Merged_Cells_and_Clean_v2()
'based on Ssaqib's version (http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28295366.html?cid=1752#a39652929)
Dim cel As Range, colcel As Range, rowcel As Range
Dim endEntireColumn As Long
Dim txt As String
Dim Rule As Range
Dim rng() As String
Dim LastRow As Long
Dim ws As Worksheet

    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Sheet1.Copy , Sheet1
    Set ws = ActiveSheet
    With ws
        endEntireColumn = .UsedRange.Columns.Count
        For Each cel In .UsedRange
            With cel
                If .MergeCells = True Then
                    LastRow = .Row + .MergeArea.Rows.Count - 1
                    For Each colcel In .MergeArea.EntireRow.Resize(, endEntireColumn).Cells
                        If colcel.MergeCells = False Then
                            txt = vbNullString
                            For Each rowcel In Intersect(.MergeArea.EntireRow, colcel.EntireColumn)
                                txt = txt & rowcel.Value & IIf(rowcel.Row = LastRow, Chr(10), vbNullString)
                            Next rowcel
                            colcel.Value = Trim(txt)
                            Intersect(.MergeArea.EntireRow, colcel.EntireColumn).Merge
                        End If
                    Next colcel
                    .EntireRow.MergeCells = False
                    With ws
                        .Range(cel.Offset(1), .Cells(LastRow, 1)).EntireRow.Delete
                    End With
                End If
            End With
        Next cel
        .Cells(1, 1).EntireColumn.Insert Shift:=xlToRight
        For Each Rule In .Range(.Cells(1, 2), .Cells(.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) = vbNullString
                    Rule.Value = rng(0)
                End If
            End If
        Next Rule
        .Columns.AutoFit
        .Rows.AutoFit
    End With

    Application.DisplayAlerts = True
    Set ws = Nothing
End Sub

Open in new window


hth
Rob
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

860 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question