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
396 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
Comment Utility
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
Comment Utility
somehow I need to get the value of the "Range" of rows included in the merged cell.
0
 
LVL 6

Author Comment

by:Dooglave
Comment Utility
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
 
LVL 6

Author Comment

by:Dooglave
Comment Utility
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
Comment Utility
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
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 
LVL 6

Author Comment

by:Dooglave
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

What is a Form List Box? (skip if you know this) The forms List Box is the alternative to the ActiveX list box. If you are using excel 2007, you first make sure you have a developer tab (click the Orb)->"Excel Options"->Popular->"Show Developer tab…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

772 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now