Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
NEED HELP!!!!
Ok I need to update over a thousand workbooks. I have a macro that will do
it but I need to know how to make it look in the subfolders for .xl folders instead of just the main. here's my code. Sub WhiteWeights() Dim Mypath As String, FilesInPath As String Dim MyFiles() As String, Fnum As Long Dim mybook As Workbook Dim CalcMode As Long Dim sh As Worksheet Dim ErrorYes As Boolean Dim Rng As Range 'Path to Folders where the files are. Mypath = "X:\Daniel Wilson\Testing Foulder\Mill Work\Corner Bumper Guards" 'Add a slash at the end if the user forgot it If Right(Mypath, 1) < "/" Then Mypath = Mypath & "/" End If 'If there are no Excel Files in the folder exit the sub FilesInPath = Dir(Mypath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found." Exit Sub End If '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 file in array If Fnum 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(Mypath & MyFiles(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then 'Change cell value(s) On Error Resume Next 'Experimental Coding Application.DisplayAlerts = False Application.ScreenUpdating = False With mybook.Worksheets("Report") Range("T78:AF80").Select Selection.Font.ColorIndex = 2 Worksheets("Data Entry").Select Range("c200:c203").Select Selection.Font.ColorIndex = 2 Range("D200") = "Weights Font White" Worksheets("Report").Select Range("I2").Select End With If Err.Number 0 Then ErrYes = True Err.Clear 'close without saving mybook.Close savechanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True Else mybook.Close savechanges:=True Application.DisplayAlerts = True Application.ScreenUpdating = True End If Else ErrorYes = True End If Next Fnum End If If ErrorYes = True Then MsgBox "There are problems in one or more files, possible problem:" _ & vbNewLine & "protected workbook/sheet or a sheet/range that not exist" End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Any help is appreciated. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
NEED HELP!!!!
I combined your code with one of my old macros. didn't fully tes the code
but I believe it should work. the code uses two subroutines to do recursive searching on all subfolders. Sub WhiteWeights() ' strFolder = "X:\Daniel Wilson\Testing Foulder\Mill Work\Corner Bumper Guards" strFolder = "c:\temp" Set fso = CreateObject _ ("Scripting.FileSystemObject") Set Folder = _ fso.GetFolder(strFolder) Call WhiteWeightsSubFolder(strFolder + "\") End Sub Sub WhiteWeightsSubFolder(strFolder) Set fso = CreateObject _ ("Scripting.FileSystemObject") Set Folder = _ fso.GetFolder(strFolder) If Folder.subfolders.Count 0 Then For Each sf In Folder.subfolders On Error GoTo 100 Call WhiteWeightsSubFolder(strFolder + sf.Name + "\") 100 Next sf End If 'folder size in bytes On Error GoTo 200 For Each fl In Folder.Files Ext = fso.GetExtensionName(fl) If UCase(Left(Ext, 2)) = "XL" Then Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(fl) On Error GoTo 0 If Not mybook Is Nothing Then 'Change cell value(s) On Error Resume Next 'Experimental Coding Application.DisplayAlerts = False Application.ScreenUpdating = False With mybook.Worksheets("Report") Range("T78:AF80").Select Selection.Font.ColorIndex = 2 Worksheets("Data Entry").Select Range("c200:c203").Select Selection.Font.ColorIndex = 2 Range("D200") = "Weights Font White" Worksheets("Report").Select Range("I2").Select End With If Err.Number 0 Then ErrYes = True Err.Clear 'close without saving mybook.Close savechanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True Else mybook.Close savechanges:=True Application.DisplayAlerts = True Application.ScreenUpdating = True End If Else ErrorYes = True End If End If Next fl 200 On Error GoTo 0 End Sub "Kiba" wrote: Ok I need to update over a thousand workbooks. I have a macro that will do it but I need to know how to make it look in the subfolders for .xl folders instead of just the main. here's my code. Sub WhiteWeights() Dim Mypath As String, FilesInPath As String Dim MyFiles() As String, Fnum As Long Dim mybook As Workbook Dim CalcMode As Long Dim sh As Worksheet Dim ErrorYes As Boolean Dim Rng As Range 'Path to Folders where the files are. Mypath = "X:\Daniel Wilson\Testing Foulder\Mill Work\Corner Bumper Guards" 'Add a slash at the end if the user forgot it If Right(Mypath, 1) < "/" Then Mypath = Mypath & "/" End If 'If there are no Excel Files in the folder exit the sub FilesInPath = Dir(Mypath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found." Exit Sub End If '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 file in array If Fnum 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(Mypath & MyFiles(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then 'Change cell value(s) On Error Resume Next 'Experimental Coding Application.DisplayAlerts = False Application.ScreenUpdating = False With mybook.Worksheets("Report") Range("T78:AF80").Select Selection.Font.ColorIndex = 2 Worksheets("Data Entry").Select Range("c200:c203").Select Selection.Font.ColorIndex = 2 Range("D200") = "Weights Font White" Worksheets("Report").Select Range("I2").Select End With If Err.Number 0 Then ErrYes = True Err.Clear 'close without saving mybook.Close savechanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True Else mybook.Close savechanges:=True Application.DisplayAlerts = True Application.ScreenUpdating = True End If Else ErrorYes = True End If Next Fnum End If If ErrorYes = True Then MsgBox "There are problems in one or more files, possible problem:" _ & vbNewLine & "protected workbook/sheet or a sheet/range that not exist" End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Any help is appreciated. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|