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

On Thursday, January 23, 2014 8:35:52 PM UTC-8, isabelle wrote:
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 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 the exception 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 the sheet the code is running on.

https://www.dropbox.com/s/phs2j66w3i...rop%20Box.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

On Friday, January 24, 2014 7:37:36 PM UTC-8, isabelle wrote:
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

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.

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

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

with range created by cell X1 and cell Y1 try:

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Saturday, January 25, 2014 4:14:18 AM UTC-8, Claus Busch wrote:
Hi Howard,



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



with range created by cell X1 and cell Y1 try:



and with skipping the colored cells try:



Regards

Claus B.


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.

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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

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

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?
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

On Saturday, January 25, 2014 9:01:44 AM UTC-8, Claus Busch wrote:
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



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



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?

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

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.

fine that it works now. Always glad to help.


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Saturday, January 25, 2014 9:24:53 AM UTC-8, Claus Busch wrote:
Hi Howard,



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



Okay, I think I got all that.



fine that it works now. Always glad to help.





Regards

Claus B.


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 he

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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

Am Sun, 26 Jan 2014 10:04:45 +0100 schrieb Claus Busch:

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

sorry the code above is to compilcated
This is enough:

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


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Sunday, January 26, 2014 2:50:00 AM UTC-8, Claus Busch wrote:
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.

--


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.

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Sunday, January 26, 2014 5:12:34 AM UTC-8, Claus Busch wrote:
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



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.

--

With all the other outstanding features you have presented to this sheet, that got lost on me. I was pondering the loss of the medium line at the bottom of the desk area due to the expanded overall area.

Then KaPow! You offer up a solution to not only solve that but the others also little ranges also.

You are a thinker and a doer!

Appreciate it.

Howard

Hi Claus,

I submitted the finished product to Samantha and here is her response, and mine to her.

Howard


Howard, you are a GENUIS!

Thank you so much! This is just what is needed... I'm really so grateful for this and thank you for your time and effort!

I really thought it might be impossible but you clearly know your stuff!!

Thank you again!

Samantha


Hi Samantha,

Glad it works for you, you may see something you need to tweak as you use it more.

The code is written largely by a true genius named Claus who is a dominate contributor along with a few others in the MS Public Excel forums.

I will take full credit for being the messenger here.

You can do this to clean up the workbook.

In Module 1 find the code that is titled as this:

Sub ReFormTheRowxxxx()
'/ by Claus

and delete it. It does nothing now and was an earlier version which has been replaced with the code headed as this:

'/ **** This Code Is In Use ****\'
'/ Assigned to the button "Reform"

Sub DayFormater()

Regards,
Howard

Hi Howard,

Am Mon, 27 Jan 2014 09:55:33 -0800 (PST) schrieb L. Howard:

I submitted the finished product to Samantha and here is her response, and mine to her.

thank you for this feedback.
I am always glad if a client is fully satisfied.
It seems like we are working good together ;-)


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2