Move and save single worksheet from multiple workbooks as new file

Question

I have an Excel workbook that serves as a document index. Column A contains 1000 filenames, and Column B contains the corresponding hyperlinks to those Excel files on the network. All of the filenames are unique.

My task is to Open each of the 1000 Excels to Move out a single worksheet and save that Worksheet as a new workbook on another location on the network. For each of the 1000 Excel documents, the worksheet I need to "extract" has the same title "Details."

Is there a way through VBA to cycle through all 1000 cells and Open the workbook via the hyperlink, Move out the "Details" worksheet, save that Details worksheet as it's own Excel file with the corresponding filename from Column A?

Does this answer your question? How to merge Worksheets from Multiple Workbooks into New WorkBook — Ken White
Thank you, Ken, but not specifically. That task is similar, but I'm more-so looking to extract the 1000 worksheets and save each as a distinct Workbook with the original filename. Conversely, I would also be okay if there is a way to go into each workbook systematically and deleting all worksheets OTHER THAN the "Details" worksheet and re-saving with existing file name. — AndyF
Do you have a header row? Is your hyperlink; text, a hyperlink, a hyperlink derived using a formula? — GMalc
OK. Search this site for [excel] save each sheet to a different file, which will find other duplicates of your question that should get you started. Please always do some intensive searching here for existing questions and answers before posting a new question. Changes are quite good that something very similar (if not exactly the same) has been asked and answered here before. — Ken White

GMalc GMalc · Accepted Answer · 2020-05-09T05:26:21

This code will open each hyperlink in column B of your "Index" worksheet, check each workbook for the specific worksheet, if found it will save the worksheet as a workbook, and name the new workbook using the corresponding text in column A. Opening 1k workbooks, then saving a worksheet as a new workbook may take awhile to complete. I've provided comments in the code to help understand what is happening.

Sub OpenWorkbooksWithHyperlinks()
Dim wsNdx As Worksheet: Set wsNdx = ThisWorkbook.Sheets("Sheet1") 'change to your workbook and sheet
'Dim wsName As String: wsName = "Details" 'define the worksheet you want to open
Dim wbLink As Range, ws As Worksheet, wsExists As Boolean

    With Application 'turn off to speed up code
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

For Each wbLink In wsNdx.Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row) 'set range to loop through
    Dim fName As String: fName = wbLink.Offset(, -1).Value2 'assign file name from column A

    If wbLink.Hyperlinks.Count > 0 Then
        ThisWorkbook.FollowHyperlink wbLink.Hyperlinks(1).Address 'open each hyperlink
    End If

    Dim wbsrce As Workbook: Set wbsrce = ActiveWorkbook 'set each workbook opened as a variable

    wsExists = False 'Define the initial Boolean value for wsExists
        For Each ws In wbsrce.Sheets 'loop through each worksheet to find "Details"
            If ws.Name = "Details" Then
                'when "Details" is found change wsExists to true and exit the For loop
                wsExists = True

                Exit For
            End If
        Next ws

        If wsExists = True Then 'Test wsExists and if True then copy the worksheet and saveas.
        'You can change the path as needed,I used "_Details" because I was saving to the same path, to keep it simple.
            ws.Copy
            Application.ActiveWorkbook.SaveAs Filename:=(ThisWorkbook.Path) & "\" & fName & "_Details" & ".xlsx"
            ActiveWorkbook.Close 'close the new workbook
            wbsrce.Close 'close the current source workbook
        End If

        'If a workbook does not have a worksheet named "Details" then this line will close wbsrce, and start the next loop
        If wsExists = False Then wbsrce.Close

Next

    With Application 'turn things back on
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

End Sub

Move and save single worksheet from multiple workbooks as new file

1 Answers