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

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

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

1 个答案: