Простой код VBA для копирования листа вызывает «Microsoft Excel перестал работать»

Question

Я проверил первые 45 других вопросов, касающихся «Excel перестал работать». Никто из тех с ответами не помог мне. По-видимому, эта проблема может возникать по-разному.

У меня есть рабочая тетрадь с 59 листами, но мне нужна только дюжина. Я написал простой макрос, который проверяет имя каждого листа, и если имя содержит «H2O» или «NG», лист копируется в другую ранее созданную мной книгу и открывается при запуске макроса. Первая попытка скопировать лист приводит к закрытию и перезапуску Excel, сопровождаемому сообщением «Microsoft Excel прекратил работать».

В рабочей книге много листов, но на ней нет элементов управления или формул или формул Active-X, нет форм и только один макрос, показанный ниже. Я мог бы скопировать листы вручную или изменить макрос, чтобы скрыть ненужные листы, но я получаю ту же ошибку с более сложным макросом, который копирует один лист из каждой из 39 рабочих книг в разных папках в одну рабочую книгу. с 39 листами, так что я действительно хотел бы знать, что вызывает это. Я использую Microsoft Office 365 ProPlus с Windows 10 версии 1709. Макрос всегда сначала сталкивается с листом «NG», поэтому строка кода, которая вызывает проблему, всегда та же, что и после «Case is =" NG "":

'Листы (SheetName). Копия после: = Рабочие книги ("История газов Генри Майо.xlsx"). Листы (GasSheetCount)'

Sub CreateWaterAndGasWorkbooks()
    Dim i As Integer
    Dim SheetName As String
    Dim SheetType As String
    Dim WaterSheetCount As Integer
    Dim GasSheetCount As Integer
    WaterSheetCount = 1
    GasSheetCount = 1

    With Range("A1")
    For i = 1 To Sheets.Count
       SheetName = Sheets(i).Name
       SheetType = ""
       If InStr(1, SheetName, "H2O") > 0 Then SheetType = "Water"
       If InStr(1, SheetName, "NG") > 0 Then SheetType = "NG"
       .Cells(i, 1).Value = SheetName 'Just for debug, so I know where
       .Cells(i, 2).Value = SheetType 'I was if it bombs.
       Select Case SheetType
       Case Is = "Water"
          Sheets(SheetName).Copy After:=Workbooks("Water History Henry Mayo.xlsx").Sheets(WaterSheetCount)
          WaterSheetCount = WaterSheetCount + 1
          Windows("Utility Cost Spreadsheets.xlsx").Activate
       Case Is = "NG"
          Sheets(SheetName).Copy After:=Workbooks("Gas History Henry Mayo.xlsx").Sheets(GasSheetCount)
          WaterSheetCount = GasSheetCount + 1
          Windows("Utility Cost Spreadsheets.xlsx").Activate
       Case Else
       'do nothing
       End Select
    Next i
    End With
End Sub

Answer 1

Хотя ошибка возникла при использовании VBA, я подозревал, что это не потому, что что-то не так с самим кодом. Я продолжил поиск и, наконец, натолкнулся на рекомендацию отключить надстройки Excel. Я отключил 2 из них (Name Manager Utility & Find Link), а теперь и мой исходный код, и улучшенную версию, внесенную работой Shari Rado.

Я обнаружил 6 обсуждений «Excel перестал работать» в StackOverflow, все с разными обстоятельствами (но в основном связанные с открытием или закрытием рабочих книг) и прочитал 45 ответов. Никто не предложил отключить надстройки. Так что, если вы один из тех людей, как Шай, которые пытаются помочь людям, которые пишут о проблемах здесь, вы должны добавить этот подход к своей сумке трюков. Вот где я нашел ответ, который работал для меня:

https://www.stellarinfo.com/blog/fix-microsoft-excel-stopped-working-error/

Answer 2

Попробуйте более короткую версию ниже, без использования Activate.

Модифицированный код

Option Explicit

Sub CreateWaterAndGasWorkbooks()

Dim WaterSheetCount As Long
Dim GasSheetCount As Long

Dim WaterWb As Workbook
Dim GasWb As Workbook
Dim Sht As Worksheet

' set the Water workbook object
Set WaterWb = Workbooks("Water History Henry Mayo.xlsx")

' set the Gas workbook object
Set GasWb = Workbooks("Gas History Henry Mayo.xlsx")

WaterSheetCount = 1
GasSheetCount = 1

' loop through all sheets
For Each Sht In ThisWorkbook.Sheets

    Select Case True ' "cheat" a little
        Case Sht.Name Like "*H2O*"
            Sht.Copy After:=WaterWb.Sheets(WaterSheetCount)
            WaterSheetCount = WaterSheetCount + 1

        Case Sht.Name Like "*NG*"
            Sht.Copy After:=GasWb.Sheets(GasSheetCount)
            WaterSheetCount = GasSheetCount + 1

        Case Else
            'do nothing

    End Select
Next Sht

End Sub