"Global" Cell Formatting

[Guest]

I have a folder full of about 300 Workbooks. Inside the Workbooks, I'm using
cell formatting text control "shrink to fit" to be able to view varying
length text strings within a width controlled column. Until now, no problem.

Just recently installed a new SW tool for job scheduling in my shop. This
tool allows you to attach Excel files to be printed automatically when you
print the schedule. However, it uses a 3rd party tool called "Autovue" to
print the Excel file, rather than using Excel. Autovue doesn't recognize the
Excel "shrink to fit" formatting and will print the cell at it's original
font size, causing some of the text at the far left of the cell to be cut
off. Autovue does recognize "Wrap text". If I open a Workbook and manually
toggle these selections, it will print ok.

Obviously, the easy answer is that Autovue should fix this problem.....but
while I'm waiting for them. I don't want to individually open hundreds of
Workbooks to fix this. Does anyone know of a way, like a script or command
line option, that I can toggle off "shrink to fit" and toggle on "Wrap text"
for all Workbooks in a folder?

 

[Guest]

Hi Philma. Take a look at Ron de Bruins site. You may be able adapt his
code to fix your cell formatting problem:
http://www.rondebruin.nl/copy3.htm. HTH
Sincerely, Michael Colvin

 

[Ron de Bruin]

Hi Philma

I reply to you private
When I have your answer I post a possible solution here

 

[Ron de Bruin]

Hi Phil

Test this one for the files in the folder C:\Data

Change it to your folder
MyPath = "C:\Data"


Sub Test_1()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim Fnum As Long
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range

'Fill in the path\folder where the files are
MyPath = "C:\Data" 'or "\\Username\SharedDocs"
'Add a slash at the end if the user forget
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

Set basebook = ThisWorkbook
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

With mybook.Worksheets(1).Cells
.WrapText = True
.ShrinkToFit = False
End With

mybook.Close savechanges:=True
Next Fnum

CleanUp:
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

Hi Phil

After reading your private mail you want to

The next logical choice is for me to globally toggle off WrapText and ShrinkText, then change all fonts in these workbooks to 10pt.
Do you have any code for that?

Try this one

Sub Test_1()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim Fnum As Long
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range

'Fill in the path\folder where the files are
MyPath = "C:\Data" 'or "\\Username\SharedDocs"
'Add a slash at the end if the user forget
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

Set basebook = ThisWorkbook
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

With mybook.Worksheets(1).Cells
.WrapText = False
.ShrinkToFit = False
.Font.Name = "Arial"
.Font.Size = 10
End With

mybook.Close savechanges:=True
Next Fnum

CleanUp:
Application.ScreenUpdating = True
End Sub

 

[Guest]

I believe this one will take care of the problem. I'll try it over the
weekend and let you know. Thanks very much for your help.