none
Copy worksheet from current workbook to New Workbook RRS feed

  • Question

  • Hi,

    I want to copy some specific sheets from my current workbook to a new workbook. For example, the worksheets to be copied are created dynamically so we can't specify the exact name in our code. Rather, we'll have to loop through Column B of "Sheet_Calculation". In the B column of Sheet_Calculation sheet all the sheet names will be present. So all the sheet names found in B column of "Sheet_Calculation" should be copied to a new workbook along with a sheet "Extract". The new workbook should be saved in the same location where my current workbook is currently placed.

     Thank You

    Sunday, January 17, 2016 7:32 AM

Answers

  • Sorry, I forgot a line:

    Sub CopySheets()
        Dim m As Long
        Dim r As Long
        Dim arrSheets() As String
        Dim n As Long
        Dim strPath As String
        ' Get the path of the active workbook
        strPath = ActiveWorkbook.Path
        ' Add a \ if necessary
        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If
        With Worksheets("Sheet_Calculation")
            ' Last used row in column B
            m = .Range("B" & .Rows.Count).End(xlUp).Row
            ' Loop through the rows
            ' 2 is the first row with a name, change as needed
            For r = 2 To m
                ' Increase count
                n = n + 1
                ' Expand array
                ReDim Preserve arrSheets(1 To n)
                ' Set new last item to name
                arrSheets(n) = .Range("B" & r).Value
            Next r
            ' Add the name of the Extract sheet
            n = n + 1
            ' Expand array
            ReDim Preserve arrSheets(1 To n)
            arrSheets(n) = "Extract"
        End With
        ' Copy the listed sheets
        Worksheets(arrSheets).Copy
        ' Save the new workbook
        ActiveWorkbook.SaveAs Filename:=strPath & "New.docx", _
            FileFormat:=xlOpenXMLWorkbook
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by JO_LO Sunday, January 17, 2016 4:42 PM
    Sunday, January 17, 2016 12:36 PM

All replies

  • Here you go. You can modify the macro to suit your needs.

    Sub CopySheets()
        Dim m As Long
        Dim r As Long
        Dim arrSheets() As String
        Dim n As Long
        Dim strPath As String
        ' Get the path of the active workbook
        strPath = ActiveWorkbook.Path
        ' Add a \ if necessary
        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If
        With Worksheets("Sheet_Calculation")
            ' Last used row in column B
            m = .Range("B" & .Rows.Count).End(xlUp).Row
            ' Loop through the rows
            ' 2 is the first row with a name, change as needed
            For r = 2 To m
                ' Increase count
                n = n + 1
                ' Expand array
                ReDim Preserve arrSheets(1 To n)
                ' Set new last item to name
                arrSheets(n) = .Range("B" & r).Value
            Next r
            ' Add the name of the Extract sheet
            n = n + 1
            arrSheets(n) = "Extract"
        End With
        ' Copy the listed sheets
        Worksheets(arrSheets).Copy
        ' Save the new workbook
        ActiveWorkbook.SaveAs Filename:=strPath & "New.docx", _
            FileFormat:=xlOpenXMLWorkbook
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Sunday, January 17, 2016 9:19 AM
  • Hi Hans,

    Thanks much for your reply. I'm getting Subscript out of range error while running this code in the below line

    arrSheets(n) = "Extract"

     If I remove the  above line and then run the code, everything is working fine. Can you please provide a quick resolution on how to fix it.

    Thank You. 

    Sunday, January 17, 2016 10:19 AM
  • Sorry, I forgot a line:

    Sub CopySheets()
        Dim m As Long
        Dim r As Long
        Dim arrSheets() As String
        Dim n As Long
        Dim strPath As String
        ' Get the path of the active workbook
        strPath = ActiveWorkbook.Path
        ' Add a \ if necessary
        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If
        With Worksheets("Sheet_Calculation")
            ' Last used row in column B
            m = .Range("B" & .Rows.Count).End(xlUp).Row
            ' Loop through the rows
            ' 2 is the first row with a name, change as needed
            For r = 2 To m
                ' Increase count
                n = n + 1
                ' Expand array
                ReDim Preserve arrSheets(1 To n)
                ' Set new last item to name
                arrSheets(n) = .Range("B" & r).Value
            Next r
            ' Add the name of the Extract sheet
            n = n + 1
            ' Expand array
            ReDim Preserve arrSheets(1 To n)
            arrSheets(n) = "Extract"
        End With
        ' Copy the listed sheets
        Worksheets(arrSheets).Copy
        ' Save the new workbook
        ActiveWorkbook.SaveAs Filename:=strPath & "New.docx", _
            FileFormat:=xlOpenXMLWorkbook
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by JO_LO Sunday, January 17, 2016 4:42 PM
    Sunday, January 17, 2016 12:36 PM
  • Copy worksheet between workbook using .NET Excel API with VB.NET, here is sample code snippet

    Dim workbook1 As New Workbook()
    workbook1.LoadFromFile("Sale.xlsx")
    Dim worksheet As Worksheet = workbook1.Worksheets(0)
    
    Dim newsheet As Worksheet = DirectCast(worksheet.Clone(worksheet.Parent), Worksheet)
    workbook1.Worksheets.Add(newsheet)
    
    workbook1.SaveToFile("NewWorkbook.xlsx")
    System.Diagnostics.Process.Start("NewWorkbook.xlsx")

    Wednesday, July 27, 2016 7:05 AM