VBA代码运行时错误无法打开文件(currupt)

时间:2018-11-02 11:35:33

标签: vba excel-vba

我试图多次将文件复制到新位置(一个用于Eate lob名称),并且在我需要从Eatch文件中删除所有不符合条件的行之后。 D出于某种原因,我有两个错误,一个指出无法打开文件(错误1004无法打开文件或文件损坏),并且如果我更改代码以将文件另存为xlsm,则不会给出任何错误,但是代码却无法执行任何操作,有什么想法吗?

这是我正在使用的代码

在此先感谢您的帮助

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

0 个答案:

没有答案