PDA

View Full Version : Solved: Apply Row 16 cell formats to all rows



frank_m
11-24-2011, 10:48 PM
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

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

p45cal
11-25-2011, 03:35 AM
try: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

frank_m
11-25-2011, 04:52 AM
Thanks p45cal.. very nice work :bow: .. 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 :thumb

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

and 18,000 rows in approx one minute
Awesome :beerchug:

p45cal
11-25-2011, 05:50 AM
63% of the macro's running time is taken up by:'- 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)")
Experiment here (xl2003, xp Pro) showed:
rng = Application.Trim(rng)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
11-25-2011, 06:21 AM
Amazing :cloud9:

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

Before change was approx 60 seconds

Thanks a million buddy :friends:

p45cal
11-25-2011, 06:56 AM
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
11-25-2011, 07:08 AM
HI again p45cal,

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

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
11-25-2011, 07:21 AM
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.
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

frank_m
12-07-2011, 03:47 AM
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.

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

and
......
'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
......
Full routine:

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

shrivallabha
12-07-2011, 08:31 AM
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]:
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

frank_m
12-07-2011, 09:24 AM
HI Shrivallabha,

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

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 :friends:

p45cal
12-08-2011, 12:48 AM
You're iterating through the columns anyway, so add an if j=1 to process column 1 (A) while doing so. Add (untested): 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

frank_m
12-08-2011, 01:39 AM
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?

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

p45cal
12-08-2011, 02:21 AM
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
12-08-2011, 12:50 PM
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 :friends:

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

frank_m
12-27-2011, 07:01 PM
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.)

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

frank_m
12-28-2011, 02:46 AM
This is starting to get to me. :banghead: , 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?

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

frank_m
12-28-2011, 10:12 AM
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
12-28-2011, 11:03 AM
I would suggest processing the trim part in two stages - columns 1-3, then columns 5 onward. Also use if j <> 4

frank_m
12-28-2011, 11:48 AM
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.

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

frank_m
12-28-2011, 02:01 PM
When I ran the new code on my actual data, I was getting a type mismatch error on strR = "'" & R.Value

I changed it to: strR = "'" & R.Text and ran it again without an error

It runs slower than mud now though. It takes about 10 or 15 minutes to process 18,000 rows, and 30 columns. No big deal, as I it would take two or three hours of tedious labor, to do the repairs manually.
---------------------------------------------------------------------
- Perhaps p45cal might swing by later and may feel so generous as to recode it more efficiently, for me :bow:
---------------------------------------------------------------------

The biggest reason I needed to do this cleanup, is because Excel gets upset sometimes when there are two many different cell formats.
(the limit is 4,000)

Some info on that here: http://www.rowingservice.com/quarrell/QAid/ It can happen out of the blue
and your workbook can suffer irreparable cell color and font color, even format removal and font size changing.


Laugh at me now, but I can provide more links on the subject if you'd like, as it happened to me more than once, costing me many hours of headaches, and half a day of down time for the office secretary.

- 4,000 different combinations sounds like a lot, but by Excels way of counting, it really is not. - Lets say for example, if column(1) has a background of red, with white font, and Column(2) in the same row has a yellow background with black font, then the next row has the same, except one of the cells has different text alignment and another has a different font size, Excel counts that as 4 different cell formats.

- Some of our users are big on the use of color, so some rows ended up with 3 or 4 combinations each.

[]

frank_m
12-28-2011, 07:38 PM
In an attempt to learn from what member p45cal had told me in a previous post about using the existing loop instead of a new one, I tried:

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 = False

'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 trim is trimmed
Dim strR As String

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

If Cells(16, j).NumberFormat = "@" Then
strR = "'" & colm.Text
colm.NumberFormat = "@"
strR = Replace(strR, "'", "")
colm.Value = strR
End If

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

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

This version causes all cells with text to be cleared because my strR variable is empty
When the code is finally modified to run faster and correctly, it seems to me now that there should be a check for null against the strR variable.

My guess is that my remaining problem must be something minor, that I did wrong with my modifications, but heck if I'm able to spot it. :doh:

frank_m
12-29-2011, 03:25 AM
This version I believe is more efficient as far as processing than my version in post#20, because the extra loop is only for every row, instead of every cell, and seems to me like it should work, but the results are "1-1" is converted to a date serial number. (as noted previously, my code version in post#20 does work correctly, is just very slow)

Dim j As Integer, i As Long
Dim rng As Range, colm As Range
Dim LastRow As Long, strR As String

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

Application.ScreenUpdating = False
Application.EnableEvents = False

'///**rng = Application.Trim(rng)**///'moved to after For i Loop
'this is the line that was causing all values to be re-valued
'to work around this, I've added a For i loop, to first check the cell format
'in the row 16 cell of the same column,
'if formated as text, converts it to a string, prefixed with an apostrophe,
'then the apostrophe is stripped back out, then the value is trimmed

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

'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

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 ' moved to after For i Loop

For i = 16 To LastRow
If colm.Cells(16, j).NumberFormat = "@" Then
strR = "'" & Trim(colm.Cells(i, j).Text)
colm.Cells(i, j).NumberFormat = "@"
strR = Replace(strR, "'", "")
colm.Cells(i, j).Text = strR
End If
Next i

colm.Value = colm.Value
'line above ensures Excel will recognize if the cell format is changed here.

rng = Application.Trim(rng)

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

Aflatoon
12-29-2011, 04:11 AM
Try this version:


Private Sub CommandButton1_Click()
Dim j As Integer, i As Long
Dim rng As Range, colm As Range
Dim LastRow As Long, strR As String

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

Application.ScreenUpdating = False
Application.EnableEvents = False

'///**rng = Application.Trim(rng)**///'moved to after For i Loop
'this is the line that was causing all values to be re-valued
'to work around this, I've added a For i loop, to first check the cell format
'in the row 16 cell of the same column,
'if formated as text, converts it to a string, prefixed with an apostrophe,
'then the apostrophe is stripped back out, then the value is trimmed

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

'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

If 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 ' moved to after For i Loop

If .Cells(16, j).NumberFormat = "@" Then
For i = 16 To LastRow
strR = "'" & Trim(.Cells(i, j).Text)
.Cells(i, j).NumberFormat = "@"
strR = Replace(strR, "'", "")
.Cells(i, j).Value = strR
Next i
End If

colm.Value = Application.Trim(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

frank_m
12-29-2011, 04:40 PM
Thanks Aflatoon,

Your version is certainly much better than what I most recently had.

However it runs about 20% slower than what I have in Post#20.

Below, I have improved on the Post#20 code a little more
by commenting out 'colm.Value = colm.Value
as I believe Excel is recognizing new format from running the Trim command
rng = Application.Trim(rng)

As awlays I appreciate your time and advice:

Sub Trim_and_Apply_Row16_and_other_formatting_criteria_to_all_rows()

'This version is by far the fastest version that does handle the "1-1" date issue as I want.
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 = False

'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.Text
R.NumberFormat = "@"
strR = Replace(strR, "'", "")
R.Value = strR
End If
Next R

'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
'I commented out this next line
'colm.Value = colm.Value
'I now believe Excel recognizes new format after Trim command
rng = Application.Trim(rng)

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

(Revised workbook attached)


[]

Aflatoon
12-30-2011, 01:47 AM
Is this still a question or is it resolved? If the former, what might the question be?

frank_m
12-30-2011, 02:46 PM
HI again Aflatoon,

Sorry for leaving it a mystery as to whether or not I consider this thread solved. - The current code I have does work.. I'm just still hoping for improvement with the time it takes to do the processing..

Before I added the extra loop for prefixing text columns cells with an apostrophe, then striping it back out after changing the cell format, the time it took to run it was only about 5 minutes, or less... Now, it takes about 20 minutes to process 18,000 rows x 30 Columns.

I don't have the luxury of being able to pre-specify which columns are text, because I want to be able to use this universally on other workbooks.

Also I'm curious as to whether or not a For each Loop is typically known to be faster than using a for i loop. - Asking that because the For ea is about 20% faster in this case.

Aflatoon
12-30-2011, 03:21 PM
For Each is faster with collections, slower with arrays.
Hard for us to test timings without more data, but I would suggest that settin entire column's number format will be faster than going cell by cell. Processing in arrays is probably your best option - if you are still seeking improvements in the new year, I will aim to have another look then, but cannot commit the time before that.

frank_m
12-30-2011, 09:13 PM
Hi Aflatoon

I've attached a new sample workbook that has 4,000 rows x 12 Columns
Enough data to be practical for testing purposes.(takes a little less than 30 seconds to run)

Thanks for your new suggestion.. I wasn’t able to figure away to get around changing the formatting to text in the For ea Loop, but I came to realize that the code was changing the entire column formatting to text in columns that had already had the format changed in the For ea loop.

To correct this I added
If .Cells(16, j).NumberFormat <> "@" Then
colm.NumberFormat = .Cells(16, j).NumberFormat
End If
so the code now only checks and changes columns number formating when they are not already text columns.

Doing this has increased the speed another 30% (quite significant.. :thumb

Thanks for giving me food for thought.

Still would like to improve on it more though, if not too much trouble, as the processing time is still a lengthily 14 minutes.
(No rush at all with the time frame for getting this improved)

New code below:

Sub Trim_and_Apply_Row16_and_specific_other_criteria_to_all_rows()
'This version is about 30% faster
'because in the previous code the text columns were being formated twice
'thanks Aflatoon, as you latest suggestion got my mind to where I could think of that
Dim j As Integer
Dim rng As Range, colm As Range
Dim LastRow As Long

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

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

Application.ScreenUpdating = False
Application.EnableEvents = False

'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.Text
R.NumberFormat = "@"
strR = Replace(strR, "'", "")
R.Value = strR
End If
If R.Column <> 9 Then R.Value = Trim(R.Value)
Next R

'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 j <> 9 Then ' skip column 9, because 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
'I commented out this next line
'colm.Value = colm.Value
'I now believe Excel recognizes new format after Trim command
If .Cells(16, j).NumberFormat <> "@" Then
colm.NumberFormat = .Cells(16, j).NumberFormat
'adding this check increased the speed 30%
End If
'rng = Application.Trim(rng)'changed to do the trimming in the For ea loop,
'because doing it here causes my formula in Column 9 to be converted to a value

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

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE

End Sub

frank_m
01-01-2012, 02:49 AM
Would someone be so kind as to look at my error handing in the For ea Loop
and tell me how I can have the code stop and select the first offending cell causing an error.

The sample workbook that I posted previously does not cause any errors,
and I cannot post the actual workbook both because it is too large to upload here and it has some sensitive data.


My data is being processed correctly as far as I can tell,
except that I know there must be a few cells that cause an error that I am skipping with on error resume next.
(when I remove on error resume next I get a type mismatch error after many thousands of rows are successfully processed.)
So I need to trace which cell issue is causing that.

Sub Trim_and_Apply_Row16_and_other_formatting_criteria_to_all_rows()
'Runs in about ten minutes
'(down from 30 minutes originaly, & down from 14 minutes last version)
Dim j As Integer
Dim rng As Range, colm As Range, r As Range
Dim LastRow As Long

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:AD" & LastRow) '-1
Application.ScreenUpdating = False
Application.EnableEvents = False

'rng = Application.Trim(rng)
'caused issues with "1-1" strings being converted to a date
'& needed error handling & to check cell format & if empty
'need help tracing a few cells causing type missmatch error
For Each R In rng
If .Cells(16, R.Column).NumberFormat = "@" Then
If Not IsEmpty(R) Then R.Value _
= StrConv(R.Text, 0) '1 =vbUpperCase, 2=vbLowerCase, 3=vbProperCase
If Not IsEmpty(R) And R.Column <> 14 Then
On Error Resume Next
r.Value = Application.WorksheetFunction.Trim(r)
On Error GoTo 0
End If
End If
Next R

'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 j <> 14 Then ' skip column 14, because 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
'next line not needed because trim function re-evaluates cell format
'colm.Value = colm.Value
If .Cells(16, j).NumberFormat <> "@" Then
colm.NumberFormat = .Cells(16, j).NumberFormat
'saves time by not checking text format twice
End If
'rng = Application.Trim(rng) 'Trimming in For ea Loop for error handling

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

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE

End Sub

frank_m
01-01-2012, 10:40 AM
I've got the Error Handler figured out. Just used some code that Mike wrote for me previously, and adjusted it slightly to fit my need.

Aflatoon - No need to work on a re-write for me if you haven't started on it yet, as it looks like I'm going to get it down to about ten minutes, which is ok. - Thanks for your help. and thanks again to P45cal

I'll consider this thread solved again, for now.. I'll track down whether or not the missmatch error is effecting anything important and will post back with that later.

'.... other code
'....
If Not IsEmpty(R) Then
On Error GoTo Err_Handler
R.Value= Application.WorksheetFunction.Trim(R)
End If
'.... other code
'....
Exit Sub
Err_Handler:
With ThisWorkbook.Sheets("error Log").Range("A65536").End(xlUp).Offset(1, 0)
.Cells(1, 1) = Err
.Cells(1, 2) = Error
.Cells(1, 3) = R.Address
End With
Resume Next

frank_m
01-02-2012, 09:27 AM
I discovered that the error in nothing to be concerned about, as it is always the bottom right final cell in the range, and there is nothing wrong with it's content.

I would like help though with Triming general format Columns and date Columns.

Column 14 should be bypassed with the trim.

I've put comments in the code below, to show one of the ways I have tried to Trim date and general formated columns, with no luck.

(Revised workbook attached)

Sub Trim_and_Apply_Row16_and_other_formatting_criteria_to_all_rows()
'runs in about ten minutes, on my actual workbook, 18,000 rows X 30 Columns, that's ok
Dim j As Integer
Dim rng As Range, colm As Range, R As Range
Dim LastRow As Long, RememAdrs As String

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

With ActiveSheet
.DisplayAutomaticPageBreaks = False
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rng = .Range("A17:N" & LastRow) '-1
Application.ScreenUpdating = False
Application.EnableEvents = False

'rng = Application.Trim(rng)
'this is the line that caused "1-1" strings to be changed to dates
'to work around this, I've added a loop to first check the cell format
'in the row 16 cell, of the same column, if it checks to be formated as text,
'the StrConv function combined with Trim, is run on it

For Each R In rng
RememAdrs = R.Address 'remember cells address for Error reporting
On Error GoTo Err_Handler

If Not IsEmpty(R) And .Cells(16, R.Column).NumberFormat = "@" Then

R.NumberFormat = "@"

'Using StrConv eliminated the need to add an apostrophe to convert to a string
R.Value = Trim(StrConv(R.Text, 0)) '1 =vbUpperCase, 2=vbLowerCase, 3=vbProperCase

End If

'could not figure out how to Trim only Columns formated as a date, or general
'I rarely ever use general, so I'm ok with that, just would like to know.

Next R

'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 j <> 14 Then ' skip column 14, because 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
'I commented out this next line
'colm.Value = colm.Value
'I now believe Excel recognizes new format from Trim, or StrConv Function
If .Cells(16, j).NumberFormat <> "@" Then
'adding this check increased the speed 30%
colm.NumberFormat = .Cells(16, j).NumberFormat
End If
'rng = Application.Trim(rng) 'changed to do the trimming in the For ea loop,
'because doing it here causes an error

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

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE
Exit Sub
Err_Handler:
With ThisWorkbook.Sheets("error Log").Range("A65536").End(xlUp).Offset(1, 0)
.Cells(1, 1) = Err 'err #
.Cells(1, 2) = Err.Description
.Cells(1, 3) = RememAdrs
End With
Err.Clear
Resume Next
End Sub

p45cal
01-04-2012, 08:39 AM
I've not looked in-depth at the code after msg#24, but see if this works for you:
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
'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.NumberFormat = .Cells(16, j).NumberFormat
colm = Application.Trim(colm)
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.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
(been away, sans internet since before christmas)

frank_m
01-04-2012, 11:02 AM
Thanks so much p45cal

Your latest version is fabulous. It handles everything just great.
-- 18,000 rows x 30 columns in my actual workbook completes the task in just 53 seconds.
(10 x faster than my best effort)

Thank you very much Sir :friends: :bow: