Merge and Center Macro

[ChinookDude]

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.

    '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]

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:

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]

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()

' 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]

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.

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.

 

[ChinookDude]

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