Border formatting row of cells

  • Thread starter Thread starter L. Howard
  • Start date Start date
L

L. Howard

With the activecell in column C selected, this does a decent job of running from C to column V and formats the cells borders as wanted.

It is a bit slow but is not dealing with massive volumes of cells and its use is not "gotta get as many as possible done as soon as possible" type scenario.

However, I am wondering if there is a way to code this to act on a specified row that does the range all at once. Say an inputbox asking for the row number.

The inputbox I can do myself, the greater hurdles are this:

You will note that the first cell borders are three sided and then the next cell is four sided. So a two cell range in the row will have a left, right, top and bottom as a solid border line and a vertical light dotted line as a divider.

Secondly the row may have some cells that are colorindex various colors. (To tell the user these cells are reserved and not available.)

On the rows with the some colors in them, I need the border formatting code to skip those and continue to column V.

Skipping the colors is my major hurdle. And staying in sequence with the cells that take three borders and the cells that take four borders.

Thanks.
Howard


Option Explicit

Sub ReFormatRow()
'/ From column C to column V

Dim i As Long

For i = 1 To 10

With ActiveCell.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With ActiveCell.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With ActiveCell.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

ActiveCell.Offset(, 1).Select

With ActiveCell.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With ActiveCell.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With ActiveCell.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With ActiveCell.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

ActiveCell.Offset(, 1).Select
Next

End Sub
 
hi Howard,

here is an example, hoping that this might help you

Sub test()
Dim lgn As Range
Dim i As Integer, y As Integer

Set lgn = Application.InputBox(Prompt:= _
"Please select a row with your Mouse to be bolded.", _
Title:="SPECIFY ROW", Type:=8)

For i = 3 To 22 ' column C to column V
For y = 1 To 4 ' xlEdge
With Cells(lgn.Row, i).Borders(y)
If i = 8 Then .LineStyle = xlContinuous Else .LineStyle = xlDot
If i > 3 And i < 22 Then .ColorIndex = 5 Else .ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next
Next
End Sub

'1 = xlEdgeLeft
'2 = xlEdgeRight
'3 = xlEdgeTop
'4 = xlEdgeBottom
'5 = xlDiagonalDown
'6 = xlDiagonalUp

isabelle
 
hi Howard,



here is an example, hoping that this might help you



Sub test()

Dim lgn As Range

Dim i As Integer, y As Integer



Set lgn = Application.InputBox(Prompt:= _

"Please select a row with your Mouse to be bolded.", _

Title:="SPECIFY ROW", Type:=8)



For i = 3 To 22 ' column C to column V

For y = 1 To 4 ' xlEdge

With Cells(lgn.Row, i).Borders(y)

If i = 8 Then .LineStyle = xlContinuous Else .LineStyle = xlDot

If i > 3 And i < 22 Then .ColorIndex = 5 Else .ColorIndex = 0

.TintAndShade = 0

.Weight = xlThin

End With

Next

Next

End Sub



'1 = xlEdgeLeft

'2 = xlEdgeRight

'3 = xlEdgeTop

'4 = xlEdgeBottom

'5 = xlDiagonalDown

'6 = xlDiagonalUp



isabelle
Click to expand...

Hi isabelle, thanks for taking a look.

I like your code as it is short and sweet. A step in the right direction but it produces borders of all dots on all four sides of the cell. With theexception of about the fourth cell in the row and the last in the row which seem to have the correct borders. Not seeing why that happens.
(I commented out the line that sets the borders to blue, as black is preferred.)

I was able to come up with code that does indeed format each cell correctly.. The bad news is its about a yard long but with screenupdating false, it runs pretty quick.

Both your code and mine fail to detect and ignore cells in the row that have highlighted color in them. Formats right over the colored cells.

That is the hurdle I cannot make work.

Here is a link if you are inclined to have a look. My code is in Module 4,right below yours. Also has some code to center-in-screen the area of thesheet the code is running on.

https://www.dropbox.com/s/phs2j66w3iq41sh/AA Copy of DeskBookings Drop Box.xlsm

On sheet named "Blank" near cell W1 is a button with my code assigned to it.. X1 and Y1 are drop downs to select the Day and the Desk line to reformat..

It is set up to run on the Monday range and Desk 9 row. Just click the Reform button to run my code on that line.

I appreciate the help.

Regards,
Howard
 
hi Howard,

here is another example, hoping that this one might help you more

Sub test()
Dim lgn As Range
Dim i As Integer, y As Integer
Dim xledging
'xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom, xlInsideVertical,
xlInsideHorizontal, xlDiagonalUp, xlDiagonalDown
xledging = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom,
xlInsideVertical)

Set lgn = Application.InputBox(Prompt:= _
"Please select a row with your Mouse to be bolded.", _
Title:="SPECIFY ROW", Type:=8)

For i = 26 To 45 Step 2 ' column Z to column AS, , two cells at once
(Step 2)
For y = LBound(xledging) To UBound(xledging) ' 5 xledging 0 to 4
With Range(Cells(lgn.Row, i), Cells(lgn.Row, i + 1)).Borders(xledging(y))
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
If i = 26 And y = 0 Then .Weight = xlMedium ' test if is the first
cell and xlEdgeLeft
If i = 44 And y = 1 Then .Weight = xlMedium ' test if is the last
cell and xlEdgeRight
If y = 4 Then .Weight = xlHairline ' 4 = xlInsideVertical
End With
Next
Next
End Sub

isabelle
 
hi Howard,



here is another example, hoping that this one might help you more



Sub test()

Dim lgn As Range

Dim i As Integer, y As Integer

Dim xledging

'xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom, xlInsideVertical,

xlInsideHorizontal, xlDiagonalUp, xlDiagonalDown

xledging = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom,

xlInsideVertical)



Set lgn = Application.InputBox(Prompt:= _

"Please select a row with your Mouse to be bolded.", _

Title:="SPECIFY ROW", Type:=8)



For i = 26 To 45 Step 2 ' column Z to column AS, , two cells at once

(Step 2)

For y = LBound(xledging) To UBound(xledging) ' 5 xledging 0 to 4

With Range(Cells(lgn.Row, i), Cells(lgn.Row, i + 1)).Borders(xledging(y))

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

If i = 26 And y = 0 Then .Weight = xlMedium ' test if is the first

cell and xlEdgeLeft

If i = 44 And y = 1 Then .Weight = xlMedium ' test if is the last

cell and xlEdgeRight

If y = 4 Then .Weight = xlHairline ' 4 = xlInsideVertical

End With

Next

Next

End Sub



isabelle
Click to expand...

I really like the compactness of this, hope I can adapt it.

I copied to a standard module and ran it, selected a row from Z to AS on prompt and hit enter. Get a Type Mismatch on this line.

For y = LBound(xledging) To UBound(xledging) ' 5 xledging 0 to 4

Am I using the code correctly selecting Z to AS?

I have had some success in using the code I posted in the link, where I can make it skip the colored cells. But it is a bit quirky on the sheet with some kinks to iron out.

The code is waaaay long and a ton of With / End With and same with Selection. But it does run quite quickly.

Can you elaborate a bit on how and what I should do with your code.

Sure appreciate it.

Howard
 
Hi Howard,

Am Fri, 24 Jan 2014 22:38:52 -0800 (PST) schrieb L. Howard:
I copied to a standard module and ran it, selected a row from Z to AS on prompt and hit enter. Get a Type Mismatch on this line.
Click to expand...

have a try for Range Z:AS with:

Sub Test()
Dim myR As Range
Dim myRng As Range
Dim rngC As Range

Set myR = Application.InputBox("Select a cell into the row to reform", _
"Borders reform", Type:=8)

Set myRng = Range(Cells(myR.Row, "Z"), Cells(myR.Row, "AS"))

For Each rngC In myRng
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlDot, xlContinuous)
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlDot, xlContinuous)
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
End With
Next
End Sub



Regards
Claus B.
 
Hi Howard,

with range created by cell X1 and cell Y1 try:

Sub TestCB()
Dim myRng As Range
Dim rngC As Range

With Sheets("BLANK")
Set myRng = Intersect(Range(.Range("X1")), _
Range(.Range("X1")).Rows(Mid(.Range("Y1"), _
InStr(.Range("Y1"), " ") + 1, 99)))
End With

If Mid(myRng.Address, 2, 1) = "C" Then

For Each rngC In myRng
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
End With
Next
Else
For Each rngC In myRng
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
End With
Next
End If
With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
End Sub

Regards
Claus B.
 
Hi Howard,

Am Sat, 25 Jan 2014 13:06:29 +0100 schrieb Claus Busch:
with range created by cell X1 and cell Y1 try:
Click to expand...

and with skipping the colored cells try:

Sub TestCB()
Dim myRng As Range
Dim rngC As Range

With Sheets("BLANK")
Set myRng = Intersect(Range(.Range("X1")), _
Range(.Range("X1")).Rows(Mid(.Range("Y1"), _
InStr(.Range("Y1"), " ") + 1, 99)))
End With

If Mid(myRng.Address, 2, 1) = "C" Then

For Each rngC In myRng
If rngC.Interior.ColorIndex = 0 Then
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
End With
End If
Next
Else
For Each rngC In myRng
If rngC.Interior.ColorIndex = 0 Then
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
End With
End If
Next
End If
With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
End Sub


Regards
Claus B.
 
Hi Howard,



Am Sat, 25 Jan 2014 13:06:29 +0100 schrieb Claus Busch:






and with skipping the colored cells try:



Regards

Claus B.
Click to expand...


Wow! That really gives me plenty to work with.

Thanks very much, Claus and isabelle.

Appreciate it.

Regards
Howard
 
Hi Howard,

Am Sat, 25 Jan 2014 07:02:09 -0800 (PST) schrieb L. Howard:
Wow! That really gives me plenty to work with.
Click to expand...

you can implement the code into ReFormTheRow and you don't need the
Select Case MyDay and the Selections and Gotos
And you also don't need the ReRow and ReRowSaturday macros.
The ranges are still defined so you also don't need to create the named
ranges into ReFormTheRow


Regards
Claus B.
 
This code below of your is working wonders!! Very pleased with it in the early testing stages. Looks like it will really do the trick.

I am calling it from the my code that sets the Day and the Desk, I assume that is how you intended it to be used.

Questions for my own enlightenment(in order as the appear in the code):

1. This returns C because the cell address is $C$n, second char = C ?
If Mid(myRng.Address, 2, 1) = "C" Then

2. With 0 it did nothing but works well with -4142. No problem with that is there?
If rngC.Interior.ColorIndex = -4142 Then
'If rngC.Interior.ColorIndex = 0 Then

3. You can see the lower half of the code is commented out and it still works perfect. Was that a typo of sort or what?

Howard



'/> with range created by cell X1 and cell Y1 try:
'/ and with skipping the colored cells try:

Sub TestCBSkipColor()
'/ by Claus
Dim myRng As Range
Dim rngC As Range

With Sheets("BLANK")
Set myRng = Intersect(Range(.Range("X1")), _
Range(.Range("X1")).Rows(Mid(.Range("Y1"), _
InStr(.Range("Y1"), " ") + 1, 99)))
End With

If Mid(myRng.Address, 2, 1) = "C" Then

For Each rngC In myRng

If rngC.Interior.ColorIndex = -4142 Then
'If rngC.Interior.ColorIndex = 0 Then
With rngC
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
xlHairline, xlThin)
End With
End With

End If

Next
'Else
' For Each rngC In myRng

' If rngC.Interior.ColorIndex = 0 Then

' With rngC
' With .Borders(xlEdgeLeft)
' .LineStyle = xlContinuous
' .ColorIndex = xlAutomatic
' .Weight = IIf(WorksheetFunction.IsOdd(rngC.Column), _
' xlHairline, xlThin)
' End With
' With .Borders(xlEdgeTop)
' .LineStyle = xlContinuous
' .ColorIndex = xlAutomatic
' .Weight = xlThin
' End With
' With .Borders(xlEdgeBottom)
' .LineStyle = xlContinuous
' .ColorIndex = xlAutomatic
' .Weight = xlThin
' End With
' With .Borders(xlEdgeRight)
' .LineStyle = xlContinuous
' .ColorIndex = xlAutomatic
' .Weight = IIf(Not WorksheetFunction.IsOdd(rngC.Column), _
' xlHairline, xlThin)
' End With
' End With

' End If

' Next
End If
With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
End Sub
 
Hi Howard,

Am Sat, 25 Jan 2014 08:53:33 -0800 (PST) schrieb L. Howard:
1. This returns C because the cell address is $C$n, second char = C ?
If Mid(myRng.Address, 2, 1) = "C" Then
Click to expand...

some ranges are in C:V some in Z:AS
The dotted border is in range C:V in the cells with odd column number
right and in range Z:AS in cells with odd column numbers left
2. With 0 it did nothing but works well with -4142. No problem with that is there?
If rngC.Interior.ColorIndex = -4142 Then
'If rngC.Interior.ColorIndex = 0 Then
Click to expand...

you know that everthing I post is tested. For me it works with
ColorIndex=0. it doesn't matter if it works for you with -4142
3. You can see the lower half of the code is commented out and it still works perfect. Was that a typo of sort or what?
Click to expand...
The upper half is for the ranges C:V. The lower half for the ranges
Z:AS. See my comment because the dotted borders in the different ranges.


Regards
Claus B.
 
Hi Howard,



Am Sat, 25 Jan 2014 08:53:33 -0800 (PST) schrieb L. Howard:







some ranges are in C:V some in Z:AS

The dotted border is in range C:V in the cells with odd column number

right and in range Z:AS in cells with odd column numbers left








you know that everthing I post is tested. For me it works with

ColorIndex=0. it doesn't matter if it works for you with -4142




The upper half is for the ranges C:V. The lower half for the ranges

Z:AS. See my comment because the dotted borders in the different ranges.





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

Okay, I think I got all that.

I hadn't got to checking the V to AS rows yet. I also know you don't make 30 lines of code typos so I was quite skeptical to ask but glad I did.

I'll get to work on the select case removal and the Gotos.

Thanks,
Howard
 
Hi Howard,

Am Sat, 25 Jan 2014 09:22:30 -0800 (PST) schrieb L. Howard:
Okay, I think I got all that.
Click to expand...

fine that it works now. Always glad to help.


Regards
Claus B.
 
Hi Howard,



Am Sat, 25 Jan 2014 09:22:30 -0800 (PST) schrieb L. Howard:






fine that it works now. Always glad to help.





Regards

Claus B.
Click to expand...

I was surprised how much stuff I had in the code module that was not needed.

Everything for all the Desks on all the days works perfect.

I attempted to add these rows to the code to work like the Desk rows do but have hit a wall with that. These are all in the same column as the Desk list for each day.

SkillTec Room
Delegate Area
Interview Room
Telephone Appt
Out of Office_1
Out of Office_2

Working with day Monday only for now and will adapt the other days when I know what I need to do.

In the Name Manager I extended the aMonDeskRng to include these row titles, and they do show as in the range in the Name Manager box.

Then I added the names to the drop down list in cell Y1.

With "aMon" selected in X1 dropdown and "Interview Room" selected in Y1 and run the code it errors out here:

With Sheets("BLANK")
Set myRng = Intersect(Range(.Range("X1")), _
Range(.Range("X1")).Rows(Mid(.Range("Y1"), _
InStr(.Range("Y1"), " ") + 1, 99)))
End With

And of course the one section of code I am most vague about, this is it. I assume because of the InStr it is looking for some part of "Desk n" (since everything is Desk something) and that as far as I can figure.

If it is a monster re-write of code, I'm inclined to leave it as is. It really does a very nice job taking care of the Desk rows.

Howard
 
Hi Howard,

Am Sat, 25 Jan 2014 16:28:32 -0800 (PST) schrieb L. Howard:
SkillTec Room
Delegate Area
Interview Room
Telephone Appt
Out of Office_1
Out of Office_2
Click to expand...

the named range for the days you can enlarge to include these areas.
Also the DeskRng range you have to enlarge analog.
Then you can change the upper part of the code to look for the row into
the DeskRng.
This could look like:

With Sheets("BLANK")
Set myRng = Range(.Range("X1"))
If Mid(myRng.Address, 2, 1) = "C" Then
myR = WorksheetFunction.Match(.Range("Y1"), _
Range(.Range("X1") & "DeskRng"), 0)
Else
myR = WorksheetFunction.Match(.Range("Y1"), _
Range(.Range("X1") & "DeskRng"), 0)
End If

Set myRng = Range(.Range("X1")).Rows(myR)
MsgBox myRng.Address
End With

For the days it is still working because the range names for the days
are correct.


Regards
Claus B.
 
Hi Howard,

I tested a bit more to make the code easier and more readable. That is
the result:

Sub TestCB()
Dim myRng As Range
Dim rngC As Range
Dim myR As Long
Dim i As Long

With Sheets("BLANK")
myR = WorksheetFunction.Match(.Range("Y1"), _
.Range(.Range("X1") & "DeskRng"), 0)

Set myRng = .Range(.Range("X1")).Rows(myR)
'MsgBox myRng.Address
End With

For i = 1 To myRng.Cells.Count
If myRng.Cells(i).Interior.Pattern = xlNone Then
With myRng.Cells(i)
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(Not WorksheetFunction.IsOdd(i), _
xlHairline, xlThin)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = IIf(WorksheetFunction.IsOdd(i), _
xlHairline, xlThin)
End With
End With
End If
Next i

With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
End Sub

No more test for column C or Z and no seperate loops for these columns.

Please check the interior color into the ranges. I guess some cells are
white instead of no color.


Regards
Claus B.
 
Hi Howard,



I tested a bit more to make the code easier and more readable. That is

the result:



Sub TestCB()

Dim myRng As Range

Dim rngC As Range

Dim myR As Long

Dim i As Long



With Sheets("BLANK")

myR = WorksheetFunction.Match(.Range("Y1"), _

.Range(.Range("X1") & "DeskRng"), 0)



Set myRng = .Range(.Range("X1")).Rows(myR)

'MsgBox myRng.Address

End With



For i = 1 To myRng.Cells.Count

If myRng.Cells(i).Interior.Pattern = xlNone Then

With myRng.Cells(i)

With .Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.Weight = IIf(Not WorksheetFunction.IsOdd(i), _

xlHairline, xlThin)

End With

With .Borders(xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.Weight = xlThin

End With

With .Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.Weight = xlThin

End With

With .Borders(xlEdgeRight)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.Weight = IIf(WorksheetFunction.IsOdd(i), _

xlHairline, xlThin)

End With

End With

End If

Next i



With Sheets("BLANK")

.Range(.Range("X1")).BorderAround _

ColorIndex:=xlAutomatic, Weight:=xlMedium

End With

End Sub



No more test for column C or Z and no seperate loops for these columns.



Please check the interior color into the ranges. I guess some cells are

white instead of no color.





Regards

Claus B.

--
Click to expand...


With this code and the enlarged ranges for Desk and Day I have Monday working perfectly.

Just a matter of adjusting the other days to match.

I appreciate your help, you make it look sooo easy.

Howard
 
Hi Howard,

Am Sun, 26 Jan 2014 03:38:14 -0800 (PST) schrieb L. Howard:
With this code and the enlarged ranges for Desk and Day I have Monday working perfectly.
Click to expand...

there is one thing that get lost:
The medium borders around the range with the new area names, e.g.
"SkillTec Room" ans "Delegate Area" and the others.

With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With

Now you get a medium border around the whole range. If the part ranges
should have a medium border around you have to extend this part with a
Select Case statement


Regards
Claus B.
 
Hi Howard,

Am Sun, 26 Jan 2014 12:44:43 +0100 schrieb Claus Busch:
With Sheets("BLANK")
.Range(.Range("X1")).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
Click to expand...

change the lower part of the code (the part above) to:

'Medium border around part of ranges
With Sheets("BLANK")
Select Case Left(.Range("Y1"), 4)
Case "Desk"
i = 1
j = 14
Case "Skil", "Dele"
i = 16
j = 2
Case "Inte"
i = 19
j = 1
Case "Tele"
i = 21
j = 1
Case "Out "
i = 23
j = 2
End Select
With .Range(.Range("X1"))
.Cells(i, 1).Resize(j, .Columns.Count).BorderAround _
ColorIndex:=xlAutomatic, Weight:=xlMedium
End With
End With


Regards
Claus B.
 
Back
Top