更改复制Sheet1以在宏中复制工作簿 [英] Change Copy Sheet1 to Copy Workbook in Macro

问题描述

我正在尝试修改以下代码，该代码将从工作簿中复制sheet1并将其保存到文件夹中，并使用一个名为CreateFolder的函数。从这里：调整将excel文件的sheet1复制到sheet1新的excel文件的代码

我已经尝试修改它来复制整个工作簿以发送到创建的文件夹通过CreateFolder。

感谢

编辑：更新代码

  Sub CopySheets（）
 
 Dim SourceWB As Workbook 
 Dim filePath As String 
 
'关闭屏幕更新和事件：
 Application.ScreenUpdating = False 
 Application.DisplayAlerts = False 
 
 
'路径指的是您的LimeSurvey工作簿
设置SourceWB = ActiveWorkbook 
 
 filePath = CreateFolder 
 
 SourceWB.SaveAs filePath 
 SourceWB.Close 
 Set SourceWB = Nothing 
 
 Application.ScreenUpdating = True 
 Application.DisplayAlerts = True 
 
 End Sub 
函数CreateFolder（）As String 
 
 Dim fso As Object，MyFolder As String 
设置fso = CreateObject（Scripting.FileSystemObject）
 
 MyFolder = ThisWorkbook.Path& \360编译存储库
 
 
如果fso.FolderExists（MyFolder）= False然后
 fso.CreateFolder（MyFolder）
如果
 
 MyFolder = MyFolder& \&格式（Now（），MMM_YYYY）
 
如果fso.FolderExists（MyFolder）= False然后
 fso.CreateFolder（MyFolder）
如果
 
 CreateFolder = MyFolder& \ 360编译仓库& &范围（CO3）& &格式（Now（），DD-MM-YY hh.mm）& .xls
设置fso = Nothing 
 
结束函数
  

解决方案

要复制整个工作簿，您可以使用以下代码

  Sub CopySheets（）
 
 
 Dim SourceWB As Workbook 
 Dim filePath As String 
 
'关闭屏幕更新和事件：
 Application.ScreenUpdating = False 
 Application.DisplayAlerts = False 
 
 
'路径是指您的LimeSurvey工作簿
设置SourceWB = Workbooks.Open（ThisWorkbook.Path&\LimeSurvey.xls）
 
 filePath = CreateFolder 
 
 SourceWB.SaveAs filePath 
 SourceWB.Close 
设置SourceWB = Nothing 
 
 Application.ScreenUpdating = True 
 Application.DisplayAlerts = True 
 
 End Sub 
函数CreateFolder（）As String 
 
 Dim fso As Object，MyFolder As String 
 Set fso = CreateObject（Scripting.FileSystemObject）
 
 MyFolder = ThisWorkbook.path& \Reports
 
 
如果fso.FolderExists（MyFolder）= False然后
 fso.CreateFolder（MyFolder）
如果
 
 MyFolder = MyFolder& \&格式（Now（），MMM_YYYY）
 
如果fso.FolderExists（MyFolder）= False然后
 fso.CreateFolder（MyFolder）
如果
 
 CreateFolder = MyFolder& \Data&格式（Now（），DD-MM-YY hh.mm.ss）& .xls
设置fso = Nothing 
 
结束函数
  

I am trying to alter the following code which copies sheet1 from the active workbook and saves it to a folder by with a function called CreateFolder, all works well.

From Here: Tweak code to copy sheet1 of a excel file to sheet1 new excel file

I have trying to alter it to copy the entire workbook to send to the the folder created by CreateFolder.

Thanks

Edit: Updated Code

Sub CopySheets()

Dim SourceWB As Workbook
Dim filePath As String

'Turns off screenupdating and events:
Application.ScreenUpdating = False
Application.DisplayAlerts = False


'path refers to your LimeSurvey workbook
Set SourceWB = ActiveWorkbook

filePath = CreateFolder

SourceWB.SaveAs filePath
SourceWB.Close
Set SourceWB = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
Function CreateFolder() As String

Dim fso As Object, MyFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")

MyFolder = ThisWorkbook.Path & "\360 Compiled Repository"


If fso.FolderExists(MyFolder) = False Then
    fso.CreateFolder (MyFolder)
End If

MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")

If fso.FolderExists(MyFolder) = False Then
    fso.CreateFolder (MyFolder)
End If

CreateFolder = MyFolder & "\360 Compiled Repository" & " " & Range("CO3") & " " & Format(Now(), "DD-MM-YY hh.mm") & ".xls"
Set fso = Nothing

End Function

解决方案

To copy entire workbook you can use the below code

Sub CopySheets()


    Dim SourceWB As Workbook
    Dim filePath As String

    'Turns off screenupdating and events:
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    'path refers to your LimeSurvey workbook
    Set SourceWB = Workbooks.Open(ThisWorkbook.Path & "\LimeSurvey.xls")

    filePath = CreateFolder

    SourceWB.SaveAs filePath
    SourceWB.Close
    Set SourceWB = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub
Function CreateFolder() As String

    Dim fso As Object, MyFolder As String
    Set fso = CreateObject("Scripting.FileSystemObject")

    MyFolder = ThisWorkbook.path & "\Reports"


    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If

    MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")

    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If

    CreateFolder = MyFolder & "\Data " & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xls"
    Set fso = Nothing

End Function

这篇关于更改复制Sheet1以在宏中复制工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！