我试图多次将文件复制到新位置(一个用于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