Question

我有代码将所有工作表从一个excel文件复制到另一个excel文件，但我只有一个工作表，当它复制时，它将原始工作文件粘贴到sheet1（2）到目标文件中。

我需要代码才能创建刚刚将sheet1传递到目标文件

的sheet1的新工作表

我试着玩它但却无法得到它

谢谢

Sub CopySheets()

Dim WB As Workbook
Dim SourceWB As Workbook
Dim WS As Worksheet
Dim ASheet As Worksheet

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

 'Sets the variables:
 Set WB = ActiveWorkbook
 Set ASheet = ActiveSheet
 Set SourceWB = Workbooks.Open(WB.Path & "\MyOtherWorkbook.xls")  'Modify to match

'Copies each sheet of the SourceWB to the end of original wb:
For Each WS In SourceWB.Worksheets
    WS.Copy after:=WB.Sheets(WB.Sheets.Count)
Next WS

    SourceWB.Close savechanges:=False
    Set WS = Nothing
    Set SourceWB = Nothing

WB.Activate
ASheet.Select
    Set ASheet = Nothing
    Set WB = Nothing

Application.EnableEvents = True

End Sub

Answer 1

尝试以下代码。如果源工作簿位于excel 2010（xlsx）且目标工作簿位于excel 2003（xls）中，则下面的代码可能会失败。您也可以查看RDBMerge Addin。

   Sub CopySheets()


    Dim SourceWB As Workbook, DestinWB As Workbook
    Dim SourceST As Worksheet
    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")
    'set source sheet
    Set SourceST = SourceWB.Sheets("Management Suite Feedback - Tri")

    SourceST.Copy
    Set DestinWB = ActiveWorkbook
    filePath = CreateFolder

    DestinWB.SaveAs filePath
    DestinWB.Close
    Set DestinWB = Nothing

    Set SourceST = Nothing
    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

调整代码将excel文件的sheet1复制到sheet1新的excel文件

1 个答案: