Ошибка времени выполнения кода VBA не могу открыть файл (currupt) - PullRequest
0 голосов
/ 02 ноября 2018

Я пытаюсь скопировать файл в новое место несколько раз (один для имени eatch lob) и после того, как мне нужно удалить из файла eatch все строки, которые не соответствуют критериям. D По какой-то причине у меня есть две ошибки, одна из которых говорит о том, что файл не может быть открыт (ошибка 1004, невозможно открыть файл или обрыв файла), и если я изменяю код для сохранения файлов в формате xlsm, это не дает никакой ошибки, но код не выполняет anithing есть идеи?

вот код, который я использую

Заранее спасибо за помощь

Sub DeleteRowBasedOnCriteria()
    Application.ScreenUpdating = False
    'lobs names
    Dim lob(15) As String

    lob(0) = "test1"
    lob(1) = "test2"
    lob(2) = "test3"
    lob(3) = "test4"
    lob(4) = "test5"
    lob(5) = "test6"
    lob(6) = "test7"
    lob(7) = "test8"
    lob(8) = "test9"
    lob(9) = "test10"
    lob(10) = "test11"
    lob(11) = "test12"
    lob(12) = "test13"
    lob(13) = "test14"
    lob(14) = "test15"

    'counter
    Dim i As Integer

    'numbers of rows
    Dim rowtotest As Long

    ' to create a copy of the template to be filled'
    Dim sDFile As String    'Destination file - Template'
    Dim sSFolder As String    'Source file  - Template'
    Dim sDFolder As String    'Destination Folder'


    'Source File Selector
    Dim sourceWindow As FileDialog
    Set sourceWindow = Application.FileDialog(msoFileDialogFilePicker)
    sourceWindow.Title = "Select Source File"

    'only select one file
    sourceWindow.AllowMultiSelect = False
    If sourceWindow.Show Then
        sSFolder = sourceWindow.SelectedItems(1)
    End If

    'Destination Path Window selector
    Dim destinationWindow As FileDialog
    Set destinationWindow = Application.FileDialog(msoFileDialogFolderPicker)
    destinationWindow.Title = "Select Destination Folder"

    'only select one folder
    destinationWindow.AllowMultiSelect = False
    If destinationWindow.Show Then
        sDFolder = destinationWindow.SelectedItems(1) + "\"
    End If

    'copy cell content to excel file based on template with bookmarks'
    Dim objExcel As Object
    Dim ws As Worksheet

    For i = 0 To 15
        'create a file with same name as lob
        sDFile = lob(i) + ".xlsx"

        'Create object excel document'
        Set FSO = CreateObject("Scripting.FileSystemObject")

        'Copy the template do destination'
        FSO.CopyFile (sSFolder), sDFolder + sDFile, True
    Next i

    Dim file As String

    For i = 0 To 15
        file = sDFolder + lob(i) + ".xlsx"
        Call GetIndices(lob(i), file)
    Next i

    MsgBox ("Individuals Criados com Sucesso!")
    Application.ScreenUpdating = True

End Sub

'Finding the superior and inferior indice and deleting the intermidial intervals
Sub GetIndices(lob As String, file As String)
    Application.ScreenUpdating = False
    'count number of rows
    Dim rowtotest As Long

    'first indice
    Dim indice1 As Integer

    'second indice
    Dim indice2 As Integer

    'variable to work with all files
    Dim ficheiro As Workbook
    Set ficheiro = Workbooks.Open(file)

    With ficheiro.Sheets(1)

        'delete rows of the other lob's
        For rowtotest = .Cells(Rows.Count, 241).End(xlUp).Row + 1 To 5 Step -1   '7 a coluna de pesquisa da lob
            If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
                indice2 = rowtotest
                rowtotest = 0    'obrigar a sair do ciclo assim que tiver encontrado os registos
            End If
        Next rowtotest

        'delete rows of the other lob's
        For rowtotest = 3 To .Cells(Rows.Count, 241).End(xlUp).Row + 1 Step 1  '4 Ž a primeira linha de registos, o que est‡ acima s‹o headers
            If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
                indice1 = rowtotest
                rowtotest = 50000  'obrigar a sair do ciclo assim que tiver encontrado os registos
            End If
        Next rowtotest

        'delete rows based on indices and create a range
        Dim texto As String
        texto = indice2 + 1 & ":" & .Cells(Rows.Count, 241).End(xlUp).Row + 1    '7 Ž a coluna de pesquisa da lob
        .Rows(texto).Delete

        If indice1 > 6 Then
            'delete rows based on indices and create a range
            texto = 3 & ":" & indice1 - 1
            .Rows(texto).Delete
        End If
    End With
    Application.ScreenUpdating = True
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...