我有一个子程序,它在作为独立宏运行时工作正常,但如果我调用它
Call selectFolderUpdateData
它不要求这部分
selectedfolder = GetFolder("C:\Users\Tim\Desktop\SampleCo 360\360 macro\360 Compiled Repository\")
它直接到
Call updateAllWorkbooks(selectedfolder)
Sub selectFolderUpdateData()
selectedfolder = GetFolder("C:\Users\Tim\Desktop\SampleCo 360\360 macro\360 Compiled Repository\")
Call updateAllWorkbooks(selectedfolder)
End Sub
谢谢
Edit
这是整个事情
Sub selectFolderUpdateData()
Dim fso As Object
Dim selectedFolder$
Set fso = CreateObject("Scripting.FileSystemObject")
Set selectedFolder = GetFolder("C:\Users\Tim\Desktop\SampleCo 360\360 macro\360 Compiled Repository\")
Call updateAllWorkbooks(selectedFolder)
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function updateAllWorkbooks(WorkDir)
Dim fso, f, fc, fl
Dim newName As String, appStr As String, SubDir As String
On Error GoTo updateAllWorkbooks_Error
SubDir = workDir & "\" & "ConvertedFiles"
SubDir = WorkDir
If Not fExists(SubDir) Then
MkDir SubDir
End If
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(WorkDir)
Set fc = f.Files
For Each fl In fc
If Right(fl, 5) = ".xlsx" Then
newName = Replace(fl, "xlsx", "xls")
newName = Replace(newName, WorkDir, SubDir)
If fExists(newName) Then
appStr = Format(Now, "hhmmss") & ".xls"
newName = Replace(newName, ".xls", appStr)
End If
Application.DisplayAlerts = False
Workbooks.Open fileName:=fl
ActiveWorkbook.SaveAs fileName:=newName, FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
End If
Next
Application.ScreenUpdating = True
On Error GoTo 0
Exit Function
updateAllWorkbooks_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure updateAllWorkbooks of Module Module2"
End Function
Function fExists(newName As String) As Boolean
Dim tester As Integer
On Error Resume Next
tester = GetAttr(newName)
Select Case Err.Number
Case Is = 0
fExists = True
Case Else
fExists = False
End Select
On Error GoTo 0
End Function
然后使用以下调用
Sub run()
Call CopySheets
Call selectFolderUpdateData
Call Deletexlxs
End Sub