CODEWITHSUNDEEP
excelvba
xyz
xyz

Reputation: 2300

Tweak code to copy sheet1 of a excel file to sheet1 new excel file

I have the code to copy all the sheets from one excel file to another, but I only have one sheet and when it copies it paste the original as sheet1 (2) in to the destination file.

I need the code to not create a new sheet just past sheet1 into sheet1 of the destination file

I tryed playing with it but could not get it

Thanks 

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

Upvotes: 1

Views: 633

Answers (1)

Santosh
Santosh

Reputation: 12353

Try below code.The below code can fail if the source workbook is in excel 2010 (xlsx) and destination workbook is in excel 2003 (xls). You may also have a look at 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

Upvotes: 1

Related Questions