Макрос для конвертирования.xls в.xlsx вылетает Excel

Question

Моя цель - преобразовать каталог, полный файлов.xls, в файлы.xlsx с сохранением встроенных изображений. Требуется автоматизированное решение, поскольку предполагаемый набор файлов составляет несколько сотен. Мой тестовый набор содержит 532 файла.xls. Открытие файлов по одному и их сохранение работает, но, очевидно, утомительно, и я бы предпочел автоматизировать.

Для этого я попытался использовать конвертер файлов Office, который говорит мне, что ни один из файлов не может быть конвертирован. Приветствия Microsoft.

Я также попробовал несколько предложений макросов. Кажется, все они заканчиваются на:

"Microsoft Excel перестал работать"

Я не смог определить причину сбоя (была бы полезна помощь в поиске полезных журналов, EventViewer, по-видимому, не содержит ничего, имеющего непосредственное значение для меня). Сначала я подумал, что это открытие файлов, а потом прочитал, что это может быть закрытие файлов. (Кажется, другие испытали это).

Запуск open с xlRepairData, похоже, не имеет значения.

Set wbk = Workbooks.Open(Filename:=strPath & strFile, CorruptLoad:=xlRepairData)

xlExtractData работает отлично, но также удаляет изображения, а не желаемое поведение!

Set wbk = Workbooks.Open(Filename:=strPath & strFile, CorruptLoad:=xlExtractData)

Затем я создал партию совершенно новых файлов.xls с изображением кролика и котенка и копировал их, пока у меня не было>50 файлов. Запуск этого тестового набора открывался и закрывался повторяюще просто отлично. AH-ХА!

Теперь у меня сложилось впечатление, что именно файлы, которые я пытаюсь открыть, вызывают проблему. В частности, я сузил один, который я могу открыть вручную в "защищенном представлении", так как Excel считает его исключительно подозрительным. К сожалению, любая попытка макроса открыть его приводит к

"Microsoft Excel перестал работать"

Я видел это много в последнее время.

К сожалению, я не могу поделиться конкретным файлом, так как он содержит данные, которые мне не разрешены, и повторное сохранение файла для удаления личных данных, скорее всего, устранит условие ошибки. (Предложения о том, как воссоздать условие в новом файле, также будут полезны).

Я попытался изменить оба предложенных решения, найденные здесь. Excel вылетает. Также иногда отображается эта ошибка во время выполнения:

"Ошибка времени выполнения" -2147021892 (80070bbc) ": Office обнаружил проблему с этим файлом. Чтобы защитить компьютер, этот файл не может быть открыт."

Я попытался пропустить файлы при обнаружении ошибки, это также заканчивается катастрофой - Excel вылетает. Есть ли правильный способ прервать операцию. Open, которая вызвала ошибку?

Sub ConvertToXlsx()
    Dim strPath As String
    Dim strFile As String
    Dim wbk As Workbook

    strPath = "C:\Test1\"
    strFile = Dir(strPath & "*.xls")
    On Error GoTo NextFile:
    Do While strFile <> ""
        If Right(strFile, 3) = "xls" Then
            Set wbk = Workbooks.Open(Filename:=strPath & strFile)
            'Save would go here
            wbk.Close SaveChanges:=False
            'Deleting the .xls file after would be a nice touch
        End If
NextFile:
        strFile = Dir
    Loop
End Sub

Я не уверен, как эффективно использовать это решение вместо этого:

 Application.ProtectedViewWindows.Open Filename:=fName
 Application.ActiveProtectedViewWindow.Edit

Есть ли хороший блок кода для запуска через каталог и открытия любого файла.xls? Он должен обрабатывать ошибки изящно и не полностью свернуть Excel. Возможно, он может проверить совместимость файла перед попыткой.Open? Excel просто не тот инструмент для работы?

Информация о быстрой настройке:
Windows 8.1 Pro - Excel 2013
Windows 10 - Excel 2013

Заранее благодарен за любую помощь в предоставлении здравомыслия.:)

---

Мой обходной путь:

Я установил LibreOffice 5 и запустил его из командной строки.
{install_dir}\program\soffice --headless --convert-to xlsx:"Calc MS Excel 2007 XML" {filename}.xlsЭто либо работает, и файл xlsx создается, либо не работает... тихо. Я использовал следующий пакетный скрипт Windows, чтобы перебрать папку с файлами xls.

@echo off

set soffice="C:\Program Files\LibreOffice 5\program\soffice"
for %%v in (*.xls) do (
    %soffice% --headless --convert-to xlsx:"Calc MS Excel 2007 XML" "%%v"
    if not exist "%%~nv.xlsx" (
        echo "ERROR: %%~nv"
    ) else (
        echo "***deleting %%v"
        del "%%v"
    )
)

После того, как скрипт завершился, было 214 файлов, которые не будут конвертированы LibreOffice, у них, похоже, нет проблем с открытием через макрос Excel (я протестировал, выполнив код Open->Close выше). Так что теперь предложенное решение и любое из решений, которые я пытался адаптировать, должны работать. Будет обновление после подтверждения.

Answer 1

ХОРОШО; поэтому следующее может работать для вас. Как уже говорилось, файлы удаляются после сохранения. В результате - если произойдет ошибка, надеюсь, вам просто нужно снова запустить макрос (или разобраться с файлом, создающим ошибки), который должен быть первым (*.xls) файлом в папке).

Sub ConvertXLStoXLSX()
    Dim sFolder As String: sFolder = "P:\Test"
    Dim wbOpen As Workbook, sFullName As String

    On Error GoTo ExitSub
    Application.ScreenUpdating = False
    For Each Item In EnumerateFiles(sFolder)
        sFullName = sFolder & "\\" & Item
        Set wbOpen = GetWorkBook(sFullName)
        Debug.Print wbOpen.Name
        Application.DisplayAlerts = False
            On Error Resume Next
                wbOpen.SaveAs FileName:=sFullName & "x", FileFormat:=xlOpenXMLWorkbook
                wbOpen.Close False
            On Error GoTo ExitSub
            If Len(Dir$(sFullName & "x")) > 0 Then Kill (sFullName)
        Application.DisplayAlerts = True
    Next Item

ExitSub:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Function EnumerateFiles(sFolder As String) As Variant
    Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder As Object: Set objFolder = objFSO.GetFolder(sFolder)
    Dim objFile As Object, V() As String

    For Each objFile In objFolder.Files
        If Right(objFile.Name, 4) = ".xls" Then
            If IsArrayAllocated(V) = False Then
                ReDim V(0)
            Else
                ReDim Preserve V(UBound(V) + 1)
            End If
            V(UBound(V)) = objFile.Name
        End If
    Next objFile

    EnumerateFiles = V
End Function

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)
End Function

Public Function GetWorkBook(ByVal sFullName As String, Optional ReadOnly As Boolean) As Workbook
    Dim sFile As String: sFile = Dir(sFullName)
    On Error Resume Next
        Set GetWorkBook = Workbooks(sFile)
        If GetWorkBook Is Nothing Then Set GetWorkBook = Workbooks.Open(sFullName, ReadOnly:=ReadOnly)
        If GetWorkBook Is Nothing Then
            Dim wbPVW As ProtectedViewWindow
            Set wbPVW = Application.ProtectedViewWindows.Open(sFullName).Edit
            Set GetWorkBook = wbPVW.Workbook
        End If
    On Error GoTo 0
End Function