Solved: Apply Row 16 cell formats to all rows

[frank_m]

Hope one of you guys or gals, can give me a much faster way of accomplishing what my code below is very slow with.

It's task is to make sure all rows in the used range match the cell formatting in row 16.

Except leave font colors as is and leave cell background color as is, unless it is white, change it to xlnone.

Please help, as what I have written below takes about ten seconds to process only 115 rows and I'm praying it's possible to get that down to about one second.

As it stands now if I try this on 18,000 rows, I can wait 30 minutes and it's not finished yet. At that point I get frustrated from not knowing if it's even making progress, so I cntrl pause break the routine.

If it is to take a very long time to run, some sort of status bar progress indicator would be nice, so I know it's doing something.

Thanks
[vba]
Sub Trim_Cells_and_Apply_Row16_formatting_to_all_rows()
Dim i As Long
Dim j As Integer
Dim rng As Range
Dim LastRow As Long
'Application.EnableCancelKey = xlDisabled
ActiveSheet.DisplayAutomaticPageBreaks = False
LastRow = Range("G" & Rows.Count).End(xlUp).Row
Set rng = Range("A16:AD" & LastRow)
Application.ScreenUpdating = False
Application.EnableEvents = False
'borrowed this command from member aflatoon.
'- It's by far the quickest way I've ever seen to Trim before and after spaces in the range
rng = Evaluate("INDEX(TRIM(" & rng.Address(0, 0, , -1) & "),0,0)")
'Scan all the rows cell formating, and make changes if necessary, to match those found in row 16
'- Ignore background color except white, change to xlnone
For i = 17 To LastRow
For j = 1 To 30
With ActiveSheet
'if cell background color is white, change it to none
If Not .Cells(i, j).Column = 14 Then ' skip processing column 14
If .Cells(i, j).Interior.ColorIndex = 2 Then
'MsgBox "The Cell at: " & .Cells(i, j).Address & _
'" has a white background that is now being changed to xlNone backgrand"
'.Cells(i, j).Activate
.Cells(i, j).Interior.ColorIndex = xlNone
End If
.Cells(i, j).HorizontalAlignment = .Cells(16, j).HorizontalAlignment
.Cells(i, j).VerticalAlignment = .Cells(16, j).VerticalAlignment
.Cells(i, j).WrapText = .Cells(16, j).WrapText
.Cells(i, j).Orientation = .Cells(16, j).Orientation
.Cells(i, j).AddIndent = .Cells(16, j).AddIndent
.Cells(i, j).IndentLevel = .Cells(16, j).IndentLevel
.Cells(i, j).ShrinkToFit = .Cells(16, j).ShrinkToFit
.Cells(i, j).Font.Name = .Cells(16, j).Font.Name
.Cells(i, j).Font.Size = .Cells(16, j).Font.Size
'Leave the existing font color left intact
'.Cells(i, j).Font.ColorIndex = .Cells(16, j).Font.ColorIndex
.Cells(i, j).NumberFormat = .Cells(16, j).NumberFormat
.Cells(i, j).Value = .Cells(i, j).Value
'line above ensures that Excel will recognize if the cell format is changed here in the code
End If
End With
Next j
Next i

'Range("A16").Activate

Application.EnableEvents = True

Application.ScreenUpdating = True
End Sub
[/vba]

[p45cal]

try:[vba]Sub Trim_Cells_and_Apply_Row16_formatting_to_all_rows()
Dim i As Long
Dim j As Integer
Dim rng As Range
Dim LastRow As Long
'Application.EnableCancelKey = xlDisabled
ActiveSheet.DisplayAutomaticPageBreaks = False
LastRow = Range("G" & Rows.Count).End(xlUp).Row
Set rng = Range("A17:AD" & LastRow)
Application.ScreenUpdating = False
Application.EnableEvents = False
'borrowed this command from member aflatoon.
'- It's by far the quickest way I've ever seen to Trim before and after spaces in the range
rng = Evaluate("INDEX(TRIM(" & rng.Address(0, 0, , -1) & "),0,0)")
'Scan all the rows' cell formatting, and make changes if necessary, to match those found in row 16
'- Ignore background color except white, change to xlnone
'For i = 17 To LastRow
For Each colm In rng.Columns
j = colm.Column
'Application.StatusBar = "row " & i & ", column " & j
With ActiveSheet
If Not j = 14 Then ' skip processing column 14
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures that Excel will recognize if the cell format is changed here in the code
End If
End With
Next colm
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = 2
Application.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
Application.FindFormat.Clear

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
[/vba]

[frank_m]

Thanks p45cal.. very nice work .. You saved the day for me once again.

I just had to add Dim colm As Range, to avoid the Excel sheet from disappearing when I tried to process 18,000 rows,
but after I did that, it looks like it's handling everything, and fast

115 rows in what seems like about 1/2 a second

and 18,000 rows in approx one minute
Awesome

[p45cal]

63% of the macro's running time is taken up by:[vba]'- It's by far the quickest way I've ever seen to Trim before and after spaces in the range
rng = Evaluate("INDEX(TRIM(" & rng.Address(0, 0, , -1) & "),0,0)")
[/vba]Experiment here (xl2003, xp Pro) showed:
[vba]rng = Application.Trim(rng)[/vba]was almost twice as fast as the Evaluate method.
So if you change this too, you might get a further 30% reduction in running time.

[frank_m]

Amazing

You latest change processes 18,000 rows x 30 columns in approx 7 seconds

Before change was approx 60 seconds

Thanks a million buddy

[p45cal]

That's a much greater speed increase than I expected - perhaps you had a greater percentage of trimming required in your 18000 rows than in the sample file you provided.

[frank_m]

HI again p45cal,

Actually I was somehow incorrect with the 7 seconds.. Must be hallucinating from lack of sleep is my best guess.

My latest testing shows your trim method speeds up the routine by about 30%, as I think you approximated might happen (runs in about 60 seconds)

When I switched back and tried using Evaluate again, it took about 90 seconds.

I was quite sure that the Evaluate code had run in about 60 seconds with several previous tests, but it might have been 70 seconds seeing that I only counted the seconds in my head, plus this old XP Home computer only has 500 mgs of ram, I guess could account for variations.

Oh, well, time to sleep.

Thanks again, you've been of enormous help.

[shrivallabha]

If you want to match column formats in all aspects [EDIT: I HAD NOT READ THE FIRST POST CAREFULLY] then something like this will work as well.
[vba]Public Sub ThisApproach()
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("A16").Resize(, 30).Copy
Range("A17:A" & Range("A" & Rows.Count).End(xlUp).Row).Resize(, 30).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/vba]

[frank_m]

Thanks for the code shrivallabha, but unfortunately the changes I need to apply are a little too unique to be done using copy.

P45cal's code works nice, however I now would like to add another instruction to the code.

If the cell in (column 1) has an interior background color of Red, I need it's font to be changed to White,

I've tried adding both of these modifications without any luck.
[vba]
'This is the first addition to the code that I tried without any joy
.......
If j = 1 And colm.Interior.ColorIndex = 3 Then colm.Font.ColorIndex = 2
......
[/vba]
and
[vba] ......
'this is the second method I tried
Application.FindFormat.Interior.ColorIndex = 3
Application.ReplaceFormat.Font.ColorIndex = 2
Application.FindFormat.Clear
'even if this method did work, I do not like it, as it is not specific to column 1
......[/vba]
Full routine:
[vba]
Sub Apply_Row16_and_other_specific_formatting_to_all_rows()
Dim i As Long
Dim j As Integer
Dim rng As Range
Dim LastRow As Long
'Application.EnableCancelKey = xlDisabled
ActiveSheet.DisplayAutomaticPageBreaks = False
LastRow = Range("G" & Rows.Count).End(xlUp).Row
Set rng = Range("A17:AD" & LastRow)
Application.ScreenUpdating = False
Application.EnableEvents = False
rng = Application.Trim(rng)
'Scan all the rows' cell formatting, and make changes if necessary, to match those found in row 16
'- if background color is white, change to xlnone
For Each colm In rng.Columns
j = colm.Column
With ActiveSheet

If Not j = 14 Then ' skip processing column 14

'I'm trying to change the font color to white in column 1,
'only if the interior color is Red, but this next line is not succeeding in doing that.
'If j = 1 And colm.Interior.ColorIndex = 3 Then colm.Font.ColorIndex = 2

colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed here.
End If
End With
Next colm
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = 2
Application.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
Application.FindFormat.Clear

'this is one of the ways I tried for changing the font color to white, --
'-- if the column 1 cell's interior color is Red, but the code below does not succeed in doing that.
'Application.FindFormat.Interior.ColorIndex = 3
'Application.ReplaceFormat.Font.ColorIndex = 2
'Application.FindFormat.Clear
'even if the few lines above did work, I do not like it, as it is not specific to column 1

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
[/vba]

[shrivallabha]

Few things:
1. There was no worksheet based event code. Is it there, in your actual file? If it is not, then Application.EnableEvents may not be necessary.

2. There is something peculiar with your posted data. The red colored cells had "P" in the cells. If that is the ONLY case where this format applies then we can also think of conditional formatting which will be more handy and we wouldn't need to handle it programmatically.

See if this works [The italic part is added which is one more loop]:
[VBA]Sub Trim_Cells_and_Apply_Row16_formatting_to_all_rows()
Dim i As Long
Dim j As Integer
Dim rng As Range, r As Range, rCol As Range
Dim LastRow As Long
'Application.EnableCancelKey = xlDisabled

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("G" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow)
Set rCol = .Range("A17:AD" & LastRow)

Application.ScreenUpdating = False
Application.EnableEvents = True

rng = Application.Trim(rng)

'Scan all the rows' cell formatting, and make changes if necessary, to match those found in row 16
'- if background color is white, change to xlnone

For Each colm In rng.Columns
j = colm.Column

If Not j = 14 Then ' skip processing column 14
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed here.
End If
Next colm

For Each r In rCol
If r.Interior.ColorIndex = 3 Then
r.Font.ColorIndex = 2
End If
Next r

End With

With Application
.FindFormat.Clear
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With

'this is one of the ways I tried for changing the font color to white, --
'-- if the column 1 cell's interior color is Red, but the code below does not succeed in doing that.
'Application.FindFormat.Interior.ColorIndex = 3
'Application.ReplaceFormat.Font.ColorIndex = 2
'Application.FindFormat.Clear
'even if the few lines above did work, I do not like it, as it is not specific to column 1

End Sub[/VBA]

[frank_m]

HI Shrivallabha,

Your loop works well and is plenty fast (at about one second, when adjusted to check only column one)


And yes the actual workbook does have worksheet event code.

Conditional formatting may be good for what this worksheet does, but there are factors that I prefer not to take the time to test for at the moment, that may make it less convenient than it seems.

Thank you much

[p45cal]

You're iterating through the columns anyway, so add an if j=1 to process column 1 (A) while doing so. Add (untested):[vba] colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures that Excel will recognize if the cell format is changed here in the code
If j = 1 Then
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = 3
Application.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
End If
End If
End With
Next colm[/vba]

[frank_m]

Thanks for your help p45cal,

Strange... the first time I ran the modified code it seemed to work, other than the fact that the sheet dissapeared for one or two seconds at the end.

I then ran it a second time and that time the red interior color cells in column 1 were all changed to no color. When what I want is to make sure that the red cells in Column 1 have a white font.

Did I add your code correctly?
[vba]
'..............
colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed here.
If j = 1 Then
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = 3
Application.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
End If
End If
Next colm
End With

With Application
.FindFormat.Clear
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With
[/vba]

[p45cal]

I told you it was untested!
Wherever you have the line:
Application.FindFormat.Clear
add immediately below it:
Application.ReplaceFormat.Clear
(There are at least three locations)

[frank_m]

Hi p45cal,

Sorry, It was not my intention at all, to sound critical. - I'm very appreciative to you for leading me through to the solution.
- Your code works very well now
[vba]
Option Explicit

Sub Trim_and_Apply_Row16_and_other_formatting_criteria_to_all_rows()
Dim j As Integer
Dim rng As Range, rCol As Range, colm As Range
Dim LastRow As Long
'Scan all rows and columns to make specific formatting changes.
'For example if background color is white in any cell, change to none.
'If cell interior color is Red in Column 1, change font to white.
'All alignments and font type and size to match row 16 cells.
With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("G" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow)
Set rCol = .Range("A17:A" & LastRow)

Application.ScreenUpdating = False
Application.EnableEvents = True

rng = Application.Trim(rng)

For Each colm In rng.Columns
j = colm.Column

If Not j = 14 Then ' skip processing column 14
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed.
If j = 1 Then
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
'If cell interior color is Red in Column 1, change font to white.
.FindFormat.Interior.ColorIndex = 3
.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
End With
End If
End If
Next colm
End With
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
'if cell interior color is white, change to none.
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub
[/vba]

[frank_m]

Found a bug in the code.

To summarize the situation,
the code below was designed to modify certain specified elements (not all) of the cell formats to match those found in (row 16 cells).

It always seems to work well with dates and numbers and most of the time for text, but not in one circumstance that i just discovered.

You'll notice that if you try to type "1-1" into a cell that is formatted general, Excel usually tries to change that to a date. That is fine, but some how my users managed to get "1-1" typed in to many thousands of cells and it remained looking like text. That is almost ok seeng that what it looks like is all that matters.. Problem is, sometimes the user types in "1-1" and gets a date, then stops and tinkers with it for a minute, to get to looking right.(adds up to a lot of wasted time), not to mention fatigue.

-- When I run code to repair the formatting to text, in many cases the before code value correctly looks like "1-1", but gets changed to a date serial number, instead of "1-1"

I believe the problem line in the code might be colm.Value = colm.Value


Please help me modify the code to remedy that.

Thanks in advanced for you time.

(As sample workbook is attached.)
[vba]
Private Sub CommandButton1_Click()
Dim j As Integer
Dim rng As Range, colm As Range
Dim LastRow As Long

On Error Resume Next
Application.EnableCancelKey = xlDisabled

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow)

Application.ScreenUpdating = False
Application.EnableEvents = True

rng = Application.Trim(rng)

'Scan all the rows' cell formatting, and make changes if necessary, to match those found in row 16
'- if background color is white, change to xlnone

For Each colm In rng.Columns
j = colm.Column

If Not j = 14 Then ' skip processing column 14
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value 'I believe I need a different command here to solve recent issue
'line above ensures Excel will recognize if the cell format is changed here.
If j = 1 Then
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 3
.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
End With
End If
End If
Next colm
End With
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

[/vba]

[frank_m]

This is starting to get to me. , please help me avoid being conquered.

My latest atempt at this was to modify the code to skip column 4 in the processing, but Excel still decides to change everything similar to "1-1" in Column 4 that is formated general, to a date (ie: "1-1" becomes 1/1/2011) - I also tried setting calcuation to manual at the begining and back to automatic at the end, with no luck.

Why does Excel insist on updating the display of the cells in Column 4 even though the code is written to skip them?
[vba]
Private Sub CommandButton1_Click()
Dim j As Integer
Dim rng As Range, colm As Range
Dim LastRow As Long

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow)

Application.ScreenUpdating = False
Application.EnableEvents = True

rng = Application.Trim(rng)

'Scan cell formatting, & make changes, to match those specified in row 16, except keep the color
'except if background is white change to none or if it is red in Column one,change font to white

For Each colm In rng.Columns
j = colm.Column

If Not j = 4 Then ' skip processing column 4
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above updates values, if the the cell format is changed by this procedure

If j = 1 Then
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 3
.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
End With
End If
End If
Next colm
End With
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub
[/vba]

[frank_m]

I discovered that rng = Application.Trim(rng) is what is causing "1-1" to be re-valued, and turned into a date.

I tried moving the Trim to after the Column 4 cell format is changed from general to text, but Excel still insists on converting it to a date.

If I can't get that worked out, I will be able to get by witout Triming, but sure hope there will be a way to do it.

Any ideas,

Thanks

[Aflatoon]

I would suggest processing the trim part in two stages - columns 1-3, then columns 5 onward. Also use [vba]if j <> 4[/vba]

[frank_m]

Hi Aflatoon,

As you were posting, I was puting the final touches on a working solution that I finally came up with.

Thanks for you time to give suggestions, I always appreciate that.

What I came up with gets around explicitly specifying which columns to do what to,
but is similar to what you said in some ways, in that I added an extra stage to the processing.

I've commented the changes in the revised code below and attached a revised sample workbook.
[vba]
Private Sub CommandButton1_Click()
Dim j As Integer
Dim rng As Range, colm As Range
Dim LastRow As Long

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow)

Application.ScreenUpdating = False
Application.EnableEvents = True

'rng = Application.Trim(rng)
'this is the line that was causing all values to be re-valued
'to work around this, I've added a loop first checks the cell format
'in the row 16 cell, of the same column, if it checks to be formated as text,
'it is converted to a string, prefixed with an apostrophe,
'then the apostrophe is stripped back out, then the value is trimmed
Dim R As Range
Dim strR As String
For Each R In rng
If Cells(16, R.Column).NumberFormat = "@" Then
strR = "'" & R.Value
R.NumberFormat = "@"
strR = Replace(strR, "'", "")
R.Value = strR
End If
Next R

rng = Application.Trim(rng)

'Scan cell formatting, & make changes, to match those specified in row 16 including font color,
'but do not use row 16 background color, except if background is white, then change to none,
'or if the Column one background is red, change it's font to white


For Each colm In rng.Columns
j = colm.Column

If Not j = 14 Then ' skip column 14, because im my actual workbook it contains a formula
colm.HorizontalAlignment = .Cells(16, j).HorizontalAlignment
colm.VerticalAlignment = .Cells(16, j).VerticalAlignment
colm.WrapText = .Cells(16, j).WrapText
colm.Orientation = .Cells(16, j).Orientation
colm.AddIndent = .Cells(16, j).AddIndent
colm.IndentLevel = .Cells(16, j).IndentLevel
colm.ShrinkToFit = .Cells(16, j).ShrinkToFit
colm.Font.Name = .Cells(16, j).Font.Name
colm.Font.Size = .Cells(16, j).Font.Size
colm.NumberFormat = .Cells(16, j).NumberFormat
colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed here.


If j = 1 Then
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 3
.ReplaceFormat.Font.ColorIndex = 2
colm.Replace What:="", Replacement:="", LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
End With
End If
End If
Next colm
End With
With Application
.FindFormat.Clear
.ReplaceFormat.Clear
.FindFormat.Interior.ColorIndex = 2
.ReplaceFormat.Interior.ColorIndex = xlNone
rng.Replace What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
.FindFormat.Clear
.ReplaceFormat.Clear
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub
[/vba]