[已解决]如何修改代码使它在加载宏里能正常运行

huchuanxing

以下是导出工作簿内各工作表成单个文件的VBA代码，把它放在工作簿里能导出工作表成单个文件，当我把代码放在加载宏里运行时，不会导出工作簿里的工作表，而是导出了加载宏里的工作表，且保存的路径是在加载宏文件夹，要使它在加载宏里能正常运行，应如何修改代码？

Sub 导出工作表()

    On Error Resume Next

    Dim FolderPath As String, FolderNameAs String, BN As String

    Dim ReturnValue As Integer

    BN = ActiveWorkbook.Name

    FolderPath = ThisWorkbook.Path

    FolderName = Mid(BN, 1, InStrRev(BN,".", Len(BN)) - 1)

    Dim MyFile As Object

    Set MyFile =CreateObject("Scripting.FileSystemObject")

    If MyFile.folderexists(FolderPath& "\" & FolderName & "-Saved") Then

        ReturnValue =MsgBox("文件夹已存在，是否更新内容？",vbOKCancel, "Caution!")

        If ReturnValue = 2 ThenExit Sub

    Else

        MyFile.CreateFolder(FolderPath & "\" & FolderName & "-Saved")

        Set MyFile = Nothing

    End If

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Dim i As Integer

    For i = 1 To Sheets.Count

        Set Wk = Workbooks.Add

       Workbooks(BN).Sheets(i).Copy before:=Wk.Worksheets("Sheet1")

        Wk.SaveAs FolderPath& "\" & FolderName & "-Saved\" &ThisWorkbook.Sheets(i).Name

        Wk.Close

    Next i

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub

最佳答案

月排行榜 / 总排行榜

苏子龙

2016-11-24 13:45

Sub 导出工作表()
    On Error Resume Next
    Dim FolderPath As String, FolderName As String, BN As String
    Dim ReturnValue As Integer, Wb As Workbook
    BN = ActiveWorkbook.Name
    Set Wb = ActiveWorkbook
    FolderPath = Wb.Path  'ThisWorkbook.Path
    FolderName = Mid(BN, 1, InStrRev(BN, ".", Len(BN)) - 1)
    Dim MyFile As Object
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    If MyFile.folderexists(FolderPath & "\" & FolderName & "-Saved") Then
        ReturnValue = MsgBox("文件夹已存在，是否更新内容？", vbOKCancel, "Caution!")
        If ReturnValue = 2 Then Exit Sub
    Else
        MyFile.CreateFolder (FolderPath & "\" & FolderName & "-Saved")
        Set MyFile = Nothing
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i As Integer
    For i = 1 To Sheets.Count
        Set wk = Workbooks.Add
       Workbooks(BN).Sheets(i).Copy    'before:=wk.Worksheets("Sheet1")
       ActiveWorkbook.SaveAs FolderPath & "\" & FolderName & "-Saved\" & Wb.Sheets(i).Name
        ActiveWorkbook.Close
        wk.Close
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
2楼老师可能是这个意思，我测试，是能用的

跳转到最佳答案楼层

hhzjxss

1. Sub 导出工作表_修正()
   
2.     On Error Resume Next
   
3.     Dim FolderPath As String, FolderName As String, BN As String
   
4.     Dim ReturnValue As Integer
   
5.     BN = ActiveWorkbook.Name
   
6.     FolderPath = ThisWorkbook.Path
   
7.     FolderName = Mid(BN, 1, InStrRev(BN, ".", Len(BN)) - 1)
   
8.     Dim MyFile As Object
   
9.     Set MyFile = CreateObject("Scripting.FileSystemObject")
   
10.     If MyFile.folderexists(FolderPath & "" & FolderName & "-Saved") Then
    
11.         ReturnValue = MsgBox("文件夹已存在，是否更新内容？", vbOKCancel, "Caution!")
    
12.         If ReturnValue = 2 Then Exit Sub
    
13.     Else
    
14.         MyFile.CreateFolder (FolderPath & "" & FolderName & "-Saved")
    
15.         Set MyFile = Nothing
    
16.     End If
    
17.     Application.ScreenUpdating = False
    
18.     Application.DisplayAlerts = False
    
19.     Dim i As Integer
    
20.     For i = 1 To Sheets.Count
    
21. '        Set Wk = Workbooks.Add
    
22.         Workbooks(BN).Sheets(i).Copy   ''before:=Wk.Worksheets("Sheet1")
    
23. ActiveWorkbook.SaveAs FolderPath & "" & FolderName & "-Saved" & ThisWorkbook.Sheets(i).Name
    
24. ActiveWorkbook.Close
    
25.     Next i
    
26.     Application.DisplayAlerts = True
    
27.     Application.ScreenUpdating = True
    
28. End Sub

复制代码

导出工作表.zip (9.68 KB, 下载次数: 6)

2016-11-24 13:05 上传

点击文件名下载附件

huchuanxing

hhzjxss 发表于 2016-11-24 13:05

我是意思是说上述代码把它做成加载宏后不能导出工作簿内的工作表成单个文件，而是导出加载宏里的工作表为单个文件。

苏子龙

Sub 导出工作表()
    On Error Resume Next
    Dim FolderPath As String, FolderName As String, BN As String
    Dim ReturnValue As Integer, Wb As Workbook
    BN = ActiveWorkbook.Name
    Set Wb = ActiveWorkbook
    FolderPath = Wb.Path  'ThisWorkbook.Path
    FolderName = Mid(BN, 1, InStrRev(BN, ".", Len(BN)) - 1)
    Dim MyFile As Object
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    If MyFile.folderexists(FolderPath & "\" & FolderName & "-Saved") Then
        ReturnValue = MsgBox("文件夹已存在，是否更新内容？", vbOKCancel, "Caution!")
        If ReturnValue = 2 Then Exit Sub
    Else
        MyFile.CreateFolder (FolderPath & "\" & FolderName & "-Saved")
        Set MyFile = Nothing
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i As Integer
    For i = 1 To Sheets.Count
        Set wk = Workbooks.Add
       Workbooks(BN).Sheets(i).Copy    'before:=wk.Worksheets("Sheet1")
       ActiveWorkbook.SaveAs FolderPath & "\" & FolderName & "-Saved\" & Wb.Sheets(i).Name
        ActiveWorkbook.Close
        wk.Close
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
2楼老师可能是这个意思，我测试，是能用的

huchuanxing

苏子龙 发表于 2016-11-24 13:45
Sub 导出工作表()
    On Error Resume Next
    Dim FolderPath As String, FolderName As String, BN A ...

谢谢您帮我解决了问题，我测试过了，完美解决。谢谢您！借此机会也对2楼老师的帮助表示感谢。

hhzjxss

哎，我又猜错你的意思了