Column Width Excel VBA Problem
 

I've got some VBA in Excel which at the moment opens up spreadsheets and
replaces 0.025 with 0.035.

I need to add some more vba in to change the column width of "Column A"
in all the worksheets within the spreadsheet except for one which is
labelled "Main Menu".

Unfortunately I did not write the original VBA and have tried very
unsuccefully to build this extra command in. I need to retain the
orgiinal functionality which opens up all the spreadsheets with the
directory one by one as have nearly 400 to change!

Can anyone help me out, here's the current VB code I'm using:

Sub replacestringall()
Dim strFile As String
Dim wbkExcel As Excel.Workbook
Dim appExcel As Excel.Application
Dim strThisDoc As String
Dim strPath As String
Dim i As Byte

strThisDoc = ActiveWorkbook.Name
strPath = ActiveWorkbook.Path

Set appExcel = New Excel.Application
appExcel.WindowState = xlMinimized
appExcel.Visible = True

With Application.FileSearch
LookIn = strPath
FileType = msoFileTypeExcelWorkbooks
SearchSubFolders = True
Execute

Range("A1") = "0 / " & .FoundFiles.Count
For i = 1 To .FoundFiles.Count
If Right(.FoundFiles(i), 4) = ".xls" Then
If InStr(.FoundFiles(i), "~$") = 0 Then
If .FoundFiles(i) < strPath & "\" & strThisDoc Then
On Error Resume Next
Set wbkExcel =
appExcel.Workbooks.Open(Filename:=.FoundFiles(i))
Select Case Err.Number
Case 0
Range("A2") = .FoundFiles(i)
wbkExcel.Activate
Dim sht As Excel.Worksheet
For Each sht In wbkExcel.Worksheets
sht.Unprotect Password:="mj22st"
appExcel.DisplayAlerts = False
sht.Cells.Replace What:="0.025,",
Replacement:="0.035,", LookAt:=xlPart, SearchOrder:=xlByRows,
MatchCase:=False
appExcel.DisplayAlerts = True
Next
wbkExcel.Save
wbkExcel.Close wdDoNotSaveChanges
Case 5408
Case Else
MsgBox Err.Number & ": " & Err.Description
End Select
On Error GoTo 0
Set wbkExcel = Nothing
End If: End If: End If
ActiveWindow.Activate
ActiveWorkbook.Activate
Range("A1") = i & " / " & .FoundFiles.Count
DoEvents
Next
End With
appExcel.Quit
Set appExcel = Nothing
Range("A2") = ""
End Sub

Thanks any help appreciated!


---
Message posted from http://www.ExcelForum.com/

Column Width Excel VBA Problem
 

Haven't dissected your code, but her is an example of code that goes through
all the sheets and sets a columnwidth

Dim sh

For Each sh In Worksheets
If sh.Name < "Main Menu" Then
sh.Columns(5).ColumnWidth = 25
End If
Next sh



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

"mrstarface " wrote in message
...
I've got some VBA in Excel which at the moment opens up spreadsheets and
replaces 0.025 with 0.035.

I need to add some more vba in to change the column width of "Column A"
in all the worksheets within the spreadsheet except for one which is
labelled "Main Menu".

Unfortunately I did not write the original VBA and have tried very
unsuccefully to build this extra command in. I need to retain the
orgiinal functionality which opens up all the spreadsheets with the
directory one by one as have nearly 400 to change!

Can anyone help me out, here's the current VB code I'm using:

Sub replacestringall()
Dim strFile As String
Dim wbkExcel As Excel.Workbook
Dim appExcel As Excel.Application
Dim strThisDoc As String
Dim strPath As String
Dim i As Byte

strThisDoc = ActiveWorkbook.Name
strPath = ActiveWorkbook.Path

Set appExcel = New Excel.Application
appExcel.WindowState = xlMinimized
appExcel.Visible = True

With Application.FileSearch
LookIn = strPath
FileType = msoFileTypeExcelWorkbooks
SearchSubFolders = True
Execute

Range("A1") = "0 / " & .FoundFiles.Count
For i = 1 To .FoundFiles.Count
If Right(.FoundFiles(i), 4) = ".xls" Then
If InStr(.FoundFiles(i), "~$") = 0 Then
If .FoundFiles(i) < strPath & "\" & strThisDoc Then
On Error Resume Next
Set wbkExcel =
appExcel.Workbooks.Open(Filename:=.FoundFiles(i))
Select Case Err.Number
Case 0
Range("A2") = .FoundFiles(i)
wbkExcel.Activate
Dim sht As Excel.Worksheet
For Each sht In wbkExcel.Worksheets
sht.Unprotect Password:="mj22st"
appExcel.DisplayAlerts = False
sht.Cells.Replace What:="0.025,",
Replacement:="0.035,", LookAt:=xlPart, SearchOrder:=xlByRows,
MatchCase:=False
appExcel.DisplayAlerts = True
Next
wbkExcel.Save
wbkExcel.Close wdDoNotSaveChanges
Case 5408
Case Else
MsgBox Err.Number & ": " & Err.Description
End Select
On Error GoTo 0
Set wbkExcel = Nothing
End If: End If: End If
ActiveWindow.Activate
ActiveWorkbook.Activate
Range("A1") = i & " / " & .FoundFiles.Count
DoEvents
Next
End With
appExcel.Quit
Set appExcel = Nothing
Range("A2") = ""
End Sub

Thanks any help appreciated!


---
Message posted from http://www.ExcelForum.com/