Импорт листов Excel 97-2003 в активную рабочую книгу

#excel #vba

#excel #vba

Вопрос:

Следующий код импортирует файлы Excel («.xlsx») по определенному пути в мою активную рабочую книгу.

 Sub GetSheets1()

    Application.ScreenUpdating = False

    Dim fPath As String, fName As String
    Dim destWB As Workbook, currentWB As Workbook
    Dim i As Long

    Set destWB = ActiveWorkbook
    fPath = "C:Usersfrancisca.cambraDropboxFaculdadeThesisMS-ProjectMacroTest"
    fName = Dir(fPath amp; "*.xlsx")
    Do While fName <> ""
        Set currentWB = Workbooks.Open(Filename:=fPath amp; fName, ReadOnly:=True)
        For i = 1 To currentWB.Sheets.Count
            currentWB.Sheets(i).Copy After:=destWB.Sheets(destWB.Sheets.Count)
        Next i
        currentWB.Close SaveChanges:=False
        fName = Dir()
    Loop

    Application.ScreenUpdating = True
    Sheets("Sheet1").Select

End Sub
  

Для файлов Excel 97-2003, когда я меняю fName = Dir(fPath amp; "*.xlsx") на fName = Dir(fPath amp; "*.xls") , рабочая книга становится пустой, без макросов и данных.

Макрос импортирует файлы Excel 97-2003, когда я комментирую currentWB.Close SaveChanges:=False строку, и он дважды копирует первую полученную книгу Excel. Я думаю, что currentWB когда-то был ActiveBook, и когда запускается макрос, ActiveBook закрывается, но я не знаю почему, поскольку ActiveBook имеет расширение, отличное от других, поэтому цикл не должен сохранять ActiveBook.

Комментарии:

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

2. В этих файлах нет никаких макросов… Я действительно не знаю, что не так.

3. Можете ли вы отлаживать и пошагово просматривать свой код и обнаруживать, когда он выходит из строя? Попробуйте выполнить это только с одним файлом .xls, возможно, с одним рабочим листом. Содержат ли рабочие книги какие-либо другие типы листов, кроме просто Worksheet? Вы также можете попробовать скопировать некоторые листы вручную, чтобы проверить, не возникает ли ошибка.

4. Спасибо @AndyG, я уже решил проблему после больших усилий…

Ответ №1:

Решено 🙂

 Sub GetSheets1()

    Application.ScreenUpdating = False

    Dim fPath As String, fName As String
    Dim destWB As Workbook, currentWB As Workbook
    Dim i As Long

    Set destWB = ActiveWorkbook
    fPath = "C:Usersfrancisca.cambraDropboxFaculdadeThesisMS-ProjectMacroTest"
    fName = Dir(fPath amp; "*.xls")
    Do While fName <> ""
        If fName <> "Blank.xlsm.xlsm" Then
            Set currentWB = Workbooks.Open(Filename:=fPath amp; fName)
            For i = 1 To currentWB.Sheets.Count
                currentWB.Sheets(i).Copy After:=destWB.Sheets(destWB.Sheets.Count)
            Next i
            currentWB.Close SaveChanges:=False
        End If
        fName = Dir()
    Loop

    Application.ScreenUpdating = True
    Sheets("Sheet1").Select

End Sub