Перемещение и сохранение одного рабочего листа из нескольких книг как нового файла

Question

У меня есть книга Excel, которая служит указателем документов. Столбец A содержит 1000 имен файлов, а столбец B содержит соответствующие гиперссылки на эти файлы Excel в сети. Все имена файлов уникальны.

Моя задача - открыть каждую из 1000 Excel, чтобы переместить один рабочий лист и сохранить этот рабочий лист как новую книгу в другом месте в сети. Для каждого из 1000 документов Excel рабочий лист, который мне нужно «извлечь», имеет тот же заголовок «Подробности».

Есть ли способ с помощью VBA циклически перебрать все 1000 ячеек и открыть книгу с помощью гиперссылки, Выдвиньте рабочий лист «Подробности», сохраните этот рабочий лист «Подробности» как собственный файл Excel с соответствующим именем файла из столбца A?

Answer 1

Этот код будет открывать каждую гиперссылку в столбце B вашего рабочего листа «Индекс», проверять каждую книгу на наличие указанного c рабочего листа, если он будет обнаружен, он сохранит рабочий лист как рабочую книгу и назовет новую книгу, используя соответствующий текст. в столбце A. Открытие 1k книг, а затем сохранение листа в качестве новой книги может занять некоторое время. Я предоставил комментарии в коде, чтобы помочь понять, что происходит.

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