Я пытаюсь скопировать файл в новое место несколько раз (один для имени 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