Merge and Center Macro

ChinookDude

New Member
Joined
Aug 10, 2010
Messages
3
Hello,

I am trying to get a macro to work but it fails (looks like it is running but does not merge) if there are any blank rows in the spreadsheet at the time the macro is executed. If there are no blank rows the macro executes correctly. I am not good at programming so I have turned to the experts. I know merge and center is the devil, but this is a final "viewing" report. At any time this spreadsheet can have up to 600 rows. Please let me know if anyone needs anymore information.

The merge and center checks each row and if there is consective same cells and then merge and centers the same cells.

Thanks in advance!!

Thanks,

Joey


Here is all of the code that I am using to accomplish this.

Code:
    'This code merges column 1 for consective same cells
          Const iCol  As Long = 1 ' pick your column
          Const iCol2  As Long = 2 ' pick your column
          Const iCol3  As Long = 3 ' pick your column
          Const iCol4  As Long = 4 ' pick your column
 
    Dim iRow    As Long
    Dim jRow    As Long
    Dim cell    As Excel.Range
    Dim rMrg    As Excel.Range
 
    iRow = 2                ' pick your start row
    Application.DisplayAlerts = False
 
    Do While Not IsEmpty(Cells(iRow, iCol))
      Set rMrg = Cells(iRow, iCol)
      jRow = 1
 
      Do While Cells(iRow + jRow, iCol).Value = Cells(iRow, iCol).Value
        Set rMrg = Union(rMrg, Cells(iRow + jRow, iCol))
        jRow = jRow + 1
      Loop
 
      rMrg.Merge
      iRow = iRow + jRow
    Loop
        iRow = 2                ' pick your start row
 
    Do While Not IsEmpty(Cells(iRow, iCol2))
      Set rMrg = Cells(iRow, iCol2)
      jRow = 1
 
      Do While Cells(iRow + jRow, iCol2).Value = Cells(iRow, iCol2).Value
        Set rMrg = Union(rMrg, Cells(iRow + jRow, iCol2))
        jRow = jRow + 1
      Loop
 
      rMrg.Merge
      iRow = iRow + jRow
    Loop
    iRow = 2                ' pick your start row
 
    Do While Not IsEmpty(Cells(iRow, iCol3))
      Set rMrg = Cells(iRow, iCol3)
      jRow = 1
 
      Do While Cells(iRow + jRow, iCol3).Value = Cells(iRow, iCol3).Value
        Set rMrg = Union(rMrg, Cells(iRow + jRow, iCol3))
        jRow = jRow + 1
      Loop
 
      rMrg.Merge
      iRow = iRow + jRow
    Loop
 
    iRow = 2                ' pick your start row
 
    Do While Not IsEmpty(Cells(iRow, iCol4))
      Set rMrg = Cells(iRow, iCol4)
      jRow = 1
 
      Do While Cells(iRow + jRow, iCol4).Value = Cells(iRow, iCol4).Value
        Set rMrg = Union(rMrg, Cells(iRow + jRow, iCol4))
        jRow = jRow + 1
      Loop
 
      rMrg.Merge
      iRow = iRow + jRow
    Loop
    Application.DisplayAlerts = True
 

Jerry Sullivan

MrExcel MVP
Joined
Mar 18, 2010
Messages
8,787
Welcome to the Board ChinookDude,

You have already acknowleged that you want to dance with the Devil, so I won't say anything about that. :)

The problem with the code is this line:

Code:
Do While Not IsEmpty(Cells(iRow, iCol))
It is saying "keep stepping down the rows until you find the first empty cell." That probably served the purpose of the original author.

You will want to change that to code that finds the last row in that column, and stops looping when iRow= the last row.

You can find plenty of examples on this Board of how to do that.

Good luck!
 

ChinookDude

New Member
Joined
Aug 10, 2010
Messages
3
Jerry,

Thank you for the reply. I wanted to say thank you for the help. I was not able to get any find end row to fix the issue. What I did stumble upon was a piece of code that selects all the blank cells in my data area, added a "space" in each blank cell, put this in front of my current merge code and Voila!! I got it to work. I wanted to say thank you again, for identifying the do not if blank. I assumed that was the issue, but we all know how that goes.

Here is the snippet of code that added incase this helps anyone out in the future:

Sub Space()


Code:
' This codes puts in a blank single space to allow the Merge code to work
    Range("A2").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = " "
    Range("A2").Select
    End Sub
Once again, I cant thank you enough, and this board has helped me in the past year get better at excel VB. Now I am on to testing Excel 2010 due to the company wants to upgrade to the new office. Got to love being the only IT guy in a warehouse!!

Thanks,

Joey
Net Admin
 

Jerry Sullivan

MrExcel MVP
Joined
Mar 18, 2010
Messages
8,787
Joey,

Putting in blank spaces was a creative approach!

Below is how the code looks taking the approach of finding the last cell in each column.

Code:
Sub Merge2()
    'This code merges columns 1-4 for consective same cells
    Dim iCol  As Long
    Dim iRow  As Long
    Dim jRow  As Long
    Dim lLastRow As Long
 
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    For iCol = 1 To 4
        lLastRow = Columns(iCol).Find(What:="*", After:=Cells(1, iCol), _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        iRow = 2 ' pick your start row
        Do While iRow <= lLastRow
            jRow = 1
            Do While Cells(iRow + jRow, iCol).Value = Cells(iRow, iCol).Value
                jRow = jRow + 1
            Loop
            Range(Cells(iRow, iCol), Cells(iRow + jRow - 1, iCol)).Merge
            iRow = iRow + jRow
        Loop
    Next iCol
End Sub



For the sake of you or others who might adapt this code for a similar purpose, I made a few other changes to make this code more efficient and easier to modify:
  • Consolidated the repeated code for each column using For....next
  • Replaced the step....Set rMrg = Union(rMrg, Cells(iRow + jRow, iCol)), which was called for each row with a single .Merge after the last consecutive value is found.
Hope this helps.
 
Last edited:

ChinookDude

New Member
Joined
Aug 10, 2010
Messages
3
Jerry,

All I can say is WOW!! I just replaced your version into my macro and the results spit out 10 times faster. Thank you seems not enough for you to take the time and help me on this. I can finally get some sleep at night!!I have to say, this is by far the best escel forum I have ever visited.

Looking forward to learn even more VB and I know this site is awsome!!

Thanks Again,

Joey
 

Forum statistics

Threads
1,081,730
Messages
5,360,934
Members
400,602
Latest member
newaqua

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top