VBA code to expand selection based on value in next cell and then merge-and-center

[amarkham]

Hi,

I have a bunch of cells with either a value, eg "x" or nothing, eg "". I am having a lot of difficulty getting started on an algorithm that iterates through each row (starting A1, going to H1, then jumping to A2 and repeating the same thing), merging-and-center'ing based on the values in each cell.

Here's how it would work. Start in cell A1. There is an "x" in the cell. Cell B1 is blank (" "), add it to the selection so now it is A1:B1. Cell C1 is also blank - add it to the selection. Cell D1 has an "x" in it, now take A1:C1 (excluding D1), merge-and-center, apply outside borders, and do the same thing with D1. If it gets to H1 (the end column) without seeing another "x" (because the remaining cells are all empty) it merges-and-centers D1:H1 then proceeds to A2 and does the same thing.

Any ideas would be awesome. Thanks.

 

[amarkham]

Sorry - scrap that, I don't need outside borders! I just need to define the start and end range.

 

[Fluff]

How about

Sub CentreSelection()
   Dim i As Long
   Dim Rng As Range
   With Range("A4:M84")
      .Value = .Value
   End With
   For i = 1 To lr
      On Error Resume Next
      For Each Rng In Range("B" & i).Resize(, 12).SpecialCells(xlBlanks).Areas
         Rng.Offset(, -1).Resize(, Rng.count + 1).HorizontalAlignment = xlCenterAcrossSelection
      Next Rng
      On Error GoTo 0
   Next i
End Sub

 

[amarkham]

That one doesn't seem to work when i copy and paste, changing the range values in Range("...") to the area I'm looking at. Is the resize based on the number of columns?

 

[Fluff]

Forgot to change the loop, try

Sub CentreSelection()
   Dim i As Long
   Dim Rng As Range
   With Range("A4:M84")
      .Value = .Value
   End With
   [COLOR=#ff0000]For i = 4 To 84[/COLOR]
      On Error Resume Next
      For Each Rng In Range("B" & i).Resize(, 12).SpecialCells(xlBlanks).Areas
         Rng.Offset(, -1).Resize(, Rng.count + 1).HorizontalAlignment = xlCenterAcrossSelection
      Next Rng
      On Error GoTo 0
   Next i
End Sub

Yes the resize is based on the columns, Cols B:M is 12 columns hence resize (,12)

 

[amarkham]

I gave this a try but it seems to only be deleting all blank cells (cells with a formula returning "") and not centering anything properly.

 

[Fluff]

Can you post some sample data?
There are tolls available to help if you follow the link in my signature

 

[amarkham]

Okay I was able to fix it for my formatting/data so your code worked. Two follow-up questions:
- I need to use this macro in many other Excel files. Is there any easy way of changing it so that all I have to do is add the range in the Name Manager (A4:M84 in the above example) and have everything else propagate through? "For i = 4 to 84" becomes a formula based on the first and last column number in the Name Manager range, the ".Resize(, 12)" similarly, etc.
- what is the simplest way of adding to the beginning of the macro, copy range C172:M177 and paste-formula to A4:M84, similarly using a range name in Name Manager?

Thank you again!!

 

[Fluff]

This will use a named range

Sub CentreSelection()
   Dim i As Long
   Dim Rng As Range, Nme As Range
   Set Nme = Range("[COLOR=#ff0000]Test[/COLOR]")
   With Nme
      .Value = .Value
   End With
   For i = 1 To Nme.Rows.count
      On Error Resume Next
      For Each Rng In Nme(i, 1).Offset(, 1).Resize(, Nme.Columns.count - 1).SpecialCells(xlBlanks).Areas
         Rng.Offset(, -1).Resize(, Rng.count + 1).HorizontalAlignment = xlCenterAcrossSelection
      Next Rng
      On Error GoTo 0
   Next i
End Sub

Change named range in red to suit

 

[amarkham]

That's great thanks. And the 2nd part of my question - if I've got a range of formulas (called "FormulaRange") that I want to copy-paste into the "Test" range from your code before I run the centreselection code, what I've done below doesn't seem to work. Any ideas?

Sub CentreSelection()
Dim i As Long
Dim Rng As Range, Nme As Range
Set Nme = Range("Test")

.Range("Test").Formula = .Range("FormulaRange").Formula

With Nme
.Value = .Value
End With
For i = 1 To Nme.Rows.Count
On Error Resume Next
For Each Rng In Nme(i, 1).Offset(, 1).Resize(, Nme.Columns.Count - 1).SpecialCells(xlBlanks).Areas
Rng.Offset(, -1).Resize(, Rng.Count + 1).HorizontalAlignment = xlCenterAcrossSelection
Next Rng
On Error GoTo 0
Next i
End Sub

 

[Fluff]

try

Range("Test").Formula = Range("FormulaRange").Formula