Question

我对VBA比较陌生，需要一些帮助才能完全理解一些问题。

我有file张多张，我需要为每个团队复制一份文件。每个文件都不得包含其他团队的信息。

我已经设法组装了这个似乎适用于一张工作表的代码，但不适用于我需要的每张工作表。

前四张纸应保持不变（在这些纸张中没有过滤），黄色纸张与其他纸张不同（我稍后需要查看），但剩下的纸张具有完全相同的结构，所以要做的专栏＆＃34;数学＆＃34;是一样的。（附件中的文件示例）

Sub DeleteRowBasedOnCriteria()

'lobs names
Dim lob(14) As String

lob(0) = "AV"
lob(1) = "CA"
lob(2) = "G_13"
lob(3) = "HSTP"
lob(4) = "JLS"
lob(5) = "JR"
lob(6) = "LPV"
lob(7) = "MAO"
lob(8) = "NML"
lob(9) = "PRJ"
lob(10) = "RB"
lob(11) = "RG"
lob(12) = "SPN"
lob(13) = "VE"

'counter
Dim i As Integer

'numbers of rows
Dim rowtotest As Long

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

sSFolder = "C:\Users\Pacosta\Desktop\ParaIndividuals\team.xlsx"

MsgBox (sSFolder)

'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 14
'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 + sFile), sDFolder + sDFile, True
Next i

Dim file As String

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

 End Sub

'delete rows diferents from lobs namefile
Sub DeleteRows(lob As String, file As String)

'disable automatic calculation
Application.Calculation = xlCalculationManual

'count number of rows
Dim rowtotest As Long

'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, 7).End(xlUp).Row + 1 To 5 Step -1
If StrComp(.Cells(rowtotest, 7).Value, lob) <> 0 Then
    .Rows(rowtotest).Delete
End If
Next rowtotest 
End With

' Force a calculation
Application.Calculate

' Then remember to run automatic calculations back on
Application.Calculation = xlCalculationAutomatic

'save file
ficheiro.Save

'close file
ficheiro.Close

End Sub

Sub GetIndices(lob As String, file As String)

'count number of rows
Dim rowtotest As Long

'primeiro indice
 Dim indice1 As Integer

 'segundo 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, 8).End(xlUp).Row + 1 To 5 Step -1
  If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
    indice2 = rowtotest
    rowtotest = 0
   End If
Next rowtotest

'delete rows of the other lob's
For rowtotest = 4 To .Cells(Rows.Count, 8).End(xlUp).Row + 1 Step 1
 If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
    indice1 = rowtotest
    rowtotest = 1000
  End If
Next rowtotest

Dim texto As String
texto = indice2 & ":" & .Cells(Rows.Count, 8).End(xlUp).Row + 1
.Rows(texto).Delete

texto = 5 & ":" & indice1
.Rows(texto).Delete

ficheiro.Save
ficheiro.Close

End With

End Sub

有人可以帮我解决这个问题吗？提前谢谢。

双循环（循环内循环）vba excel

0 个答案: