VBA: цикл копирования / вставки учитывает только последний лист / перезаписывает предыдущие листы

Question

Ожидаемая ситуация: У меня есть цикл, который проверяет все листы рабочей книги на наличие определенных ключевых слов, копирует / вставляет их в соответствии с определенными условиями и создает новую рабочую книгу для каждого листа с указанными значениями.

Пример:

Исходная рабочая книга с Sheet1, Sheet2 и Sheet3 ---> New_Workbook_1 (сзначения Sheet1), New_Workbook_2 (со значениями Sheet2), New_Workbook_3 (со значениями Sheet3)

Фактическая ситуация: вставляются только значения последнего листа рабочей книгив недавно созданные рабочие книги ... Я не могу сказать, почему?.

Пример:

Исходная рабочая книга с Sheet1, Sheet2 и Sheet3 ---> New_Workbook_1 (со значениями Sheet3), New_Workbook_2 (со значениями Sheet3), New_Workbook_3 (со значениями Sheet3)

Public Sub TransferFile(TemplateFile As String, SourceFile As String)
    Dim wbSource As Workbook
    Set wbSource = Workbooks.Open(SourceFile) 'open source

    Dim rFnd As Range
    Dim r1st As Range
    Dim ws As Worksheet
    Dim arr(1 To 4) As Variant
    Dim i As Long

    Dim wbTemplate As Workbook
    Dim NewWbName As String

    Dim wsSource As Worksheet
    For Each wsSource In wbSource.Worksheets 'loop through all worksheets in source workbook
        Set wbTemplate = Workbooks.Open(TemplateFile) 'open new template

        '/* Definition of the value range */

arr(1) = "XX"
arr(2) = "Data 2"
arr(3) = "Test 3"
arr(4) = "XP35"

For i = LBound(arr) To UBound(arr)
    For Each ws In wbSource.Worksheets
        Debug.Print ws.Name
        Set rFnd = ws.UsedRange.Find(what:=arr(i), LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlRows, _
                                    SearchDirection:=xlNext, MatchCase:=False)
        If Not rFnd Is Nothing Then
            Set r1st = rFnd
            Do
                If i = 1 Then
                    wbTemplate.Sheets("Header").Range("A3").Value = "XX"  

                ElseIf i = 2 Then
                    wbTemplate.Sheets("Header").Range("B9").Value = rFnd.Offset(0, 1).Value 


                ElseIf i = 3 Then
                   wbTemplate.Sheets("Header").Range("D7").Value = rFnd.Offset(0, 2).Value  



                ElseIf i = 4 Then
                    wbTemplate.Sheets("MM1").Range("A8").Value = "2" 


                End If
                Set rFnd = ws.UsedRange.FindNext(rFnd)
            Loop Until r1st.Address = rFnd.Address
        End If
    Next
Next


NewWbName = Left(wbSource.Name, InStr(wbSource.Name, ".") - 1)

For i = 1 To 9
    'check for existence of proposed filename
    If Len(Dir(wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx")) = 0 Then
        wbTemplate.SaveAs wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx"
        Exit For
    End If
Next i


    wbTemplate.Close False 'close template
    Next wsSource

    wbSource.Close False 'close source

End Sub

Answer 1

Поместите точку останова в строку (нажав F9 в этой строке) и запустите программу.Когда vba остановился на этой строке, прежде чем нажать F5 для продолжения, перейдите в свою папку и откройте вновь созданную книгу и посмотрите, правда это или нет.продолжить и поделиться результатами, чтобы выяснить, в чем проблема.