Question

这是我将工作表复制到新工作表的代码。当我在Workbooks.Open(path)上使用断点运行程序时它运行正常但是当我没有断点运行时它只是打开工作簿而不创建任何工作表。
我尽力纠正错误，但我无法得到理想的结果。

Sub CopyCat()    

Dim ws As Worksheet
Dim no As Integer
Set ws1 = ActiveSheet
Dim path As String

temp_name = InputBox("Enter the Sheet No to be Created", "Enter the Value")

For Loop1 = 1 To ws1.UsedRange.Rows.Count
    path = Application.ActiveWorkbook.path & "\" & Application.WorksheetFunction.Trim(Trim(ws1.Cells(Loop1, 1).Value)) & " " & ws1.Cells(Loop1, 2).Value & ".xlsx"

    Set wb1 = Workbooks.Open(path)

    'ListBox1.AddItem wb.Name
    temp_name = "Sheet" & temp_name

    'error1 = CheckSheet(wb1, temp_name)
    'If (error1 <> True) Then
    ws1.Cells(4, 1).Value = "Created" & CStr(Loop1)
    Set ws = wb1.Worksheets(Sheets.Count)

    ws.Copy After:=wb1.Sheets(Sheets.Count)
    Set ws = ActiveSheet
    ws.Name = temp_name

    'Call PageSetting
    wb1.Close SaveChanges:=True
    ws1.Cells(4, 1).Value = "Created Done" & CStr(Loop1)
    'Else
    'wb1.Close SaveChanges:=True
    'End If
Next Loop1

End Sub


Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean

Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean

For Each oSheet In wb.Sheets

    If oSheet.Name = sSheetName Then
        bReturn = True
        Exit For
    End If

Next oSheet

CheckSheet = bReturn

End Function

Answer 1

这个问题有点模糊，所以我根据你提供的代码假设了一些东西。

您希望将工作表从运行宏的工作簿复制到另一个Excel文件。

所有文件名都列在源工作表A列中 - 让我们称之为“接口”工作表。

您需要在项目中添加对Microsoft Scripting Runtime的引用，以使FileSystemObject正常工作。

下面的代码并没有很好地编写或优化，但它确实有效。

Sub CopySht(NamesRange As Range, NameOfSheetToCopy As String)

Dim fso As FileSystemObject, oFile As File, fPath As String, fNamesArr() As Variant, fFolder As Folder
Set fso = New FileSystemObject

Dim InputWb As Workbook, InterfaceWs As Worksheet
Set InputWb = ThisWorkbook
Set InterfaceWs = InputWb.Worksheets("Interface")

Dim SheetToCopy As Worksheet
Set SheetToCopy = InputWb.Worksheets(NameOfSheetToCopy)

Set NamesRange = InterfaceWs.Range(NamesRange.Address)



fNamesArr() = NamesRange.Value

fPath = InputWb.path
Set fFolder = fso.GetFolder(fPath)

Dim i As Integer

For Each oFile In fFolder.Files
    For i = LBound(fNamesArr) To UBound(fNamesArr)
        If oFile.Name = fNamesArr(i, 1) & ".xls" Or oFile.Name = fNamesArr(i, 1) & ".xlsx" Then

            On Error Resume Next
            If Not (Workbooks(oFile.Name) Is Nothing) Then
                Workbooks(oFile.Name).Close SaveChanges:=False
            End If

            Workbooks.Open (oFile.path)

            If Not (CheckSheet(Workbooks(oFile.Name), SheetToCopy.Name)) Then
                SheetToCopy.Copy After:=Workbooks(oFile.Name).Sheets(1)
                Workbooks(oFile.Name).Close SaveChanges:=True
            End If

            If Not (Workbooks(oFile.Name) Is Nothing) Then
                Workbooks(oFile.Name).Close SaveChanges:=False
            End If

        End If
    Next i
Next oFile


End Sub

Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean

    Dim oSheet As Excel.Worksheet
    Dim bReturn As Boolean

    For Each oSheet In wb.Sheets

        If oSheet.Name = sSheetName Then

            bReturn = True
            Exit For

        End If

    Next oSheet

    CheckSheet = bReturn

End Function

将NamesRange作为限定或不合格的范围对象传递无关紧要，如下所示

Sub Wrapper()

    CopySht Range("A1:A6"), "CopyMe"
    'CopySht ThisWorkbook.Worksheets("Interface").Range("A1:A6"), "CopyMe"

End Sub

VBA Excel程序仅适用于断点

1 个答案: