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
409 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
 
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
ms office troubleshooting for users 8 36
InStr Function not working properly in macro 3 19
Easy Excel formula needed 4 27
simple vba query 8 22
Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

867 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

18 Experts available now in Live!

Get 1:1 Help Now