VBA：复制/粘贴循环仅考虑最后一张纸/覆盖前一张纸答案

【问题标题】：VBA: copy/paste loop only takes the last sheet into account/overwriting previous sheetsVBA：复制/粘贴循环仅考虑最后一张纸/覆盖前一张纸
【发布时间】：2018-09-25 10:24:43
【问题描述】：

预期情况：我有一个循环，它正在检查工作簿的所有工作表中的某些关键字，根据某些条件复制/粘贴它们，并为具有上述值的每个工作表创建一个新工作簿.

示例：

带有 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

【问题讨论】：

标签： vba excel

【解决方案1】：

在行上放置一个断点（在该行中按 F9）并运行程序。当 vba 在该行停止时，在按 F5 继续之前，转到您的文件夹并打开新创建的工作簿，看看它是否正确。继续并分享结果以找出问题所在。

【讨论】：