Question

我尝试创建一个可以收集每个＆＃34; UTP＆＃34;将一个文件夹中的一张放入一个＆＃34; Master UTP＆＃34;工作簿（位于同一文件夹中）

所以，首先我需要读取文件夹中的所有文件xls。复制＆＃34; UTP＆＃34;将其粘贴并粘贴到＆＃34; Master UTP＆＃34;。然后再循环。

这是我到目前为止制作的代码＆＃34; Master UTP＆＃34;：

Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim sourceWb As Workbook, targetWb As Workbook

Set sourceWb = ActiveWorkbook

sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)

Do While Len(sFileName) > 0
    sFileName = sPathName & sFileName

    If sFileName <> sourceWb Then
        Set targetWb = Workbooks.Open(sName)
        targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
        targetWb.Close
    End If

    sFileName = Dir
Loop
End Sub

这个程序还有一些错误。请帮忙。感谢。

Answer 1

在@chrisneilsen的解决方案的基础上，这里有一个更紧凑的代码：

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        If sFileName <> targetSht.Parent.Name Then
            On Error Resume Next
            With Workbooks.Open(sPathName & sFileName)
                .Sheets("UTP").Copy After:=targetSht
                .Close False
            End With
            On Error GoTo 0
        End If
        sFileName = Dir
    Loop
End Sub

如果可以安全地假设ActiveWorkbook是＆＃34;宏＆＃34;那么它应该更加紧凑。一个，即用＆＃34; xlsm＆＃34;键入其名称，以便它永远不会匹配任何＆＃34; xls＆＃34;名：

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        On Error Resume Next
        With Workbooks.Open(sPathName & sFileName)
            .Sheets("UTP").Copy After:=targetSht
            .Close False
        End With
        On Error GoTo 0
        sFileName = Dir
    Loop
End Sub

最后，您可以欣赏消除任何xls文件打开时的闪烁，因此您可以将循环包含在Application.ScreenUpdating = False/True语句中：

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Application.ScreenUpdating = False
    Do While Len(sFileName) > 0
        On Error Resume Next
        With Workbooks.Open(sPathName & sFileName)
            .Sheets("UTP").Copy After:=targetSht
            .Close False
        End With
        On Error GoTo 0
        sFileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Answer 2

第一个问题是您尝试打开sName而不是sFileName（使用Option Explicit会检测到此错误）

第二个问题，您正在将字符串与If sFileName <> sourceWb Then

中的工作簿进行比较

第三个问题，workbook.name不包括路径

您的代码，重构和添加的错误处理

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim sourceWb As Workbook, targetWb As Workbook
    Dim ws As Worksheet

    Set sourceWb = ActiveWorkbook

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        If sFileName <> sourceWb.Name Then ' <-- sourceWb.Name does not include path
            Set targetWb = Nothing
            On Error Resume Next ' <-- in case Open fails
                Set targetWb = Workbooks.Open(sPathName & sFileName) '<-- use correct variable sFileName
            On Error GoTo 0
            If Not targetWb Is Nothing Then
                Set ws = Nothing
                On Error Resume Next ' <-- in case sheet does not exist
                    Set ws = targetWb.Worksheets("UTP")
                On Error Resume Next
                If Not ws Is Nothing Then
                    ws.Copy After:=sourceWb.Worksheets("Master UTP")
                End If
                targetWb.Close False 
            End If
        End If

        sFileName = Dir
    Loop
End Sub

Answer 3

除了您尝试打开其他工作簿的错误外，您的代码看起来很好。您尝试从未使用的变量sName打开工作簿。您还不必重置sFileName变量，而是尝试使用sPathName & sFileName作为Workbooks.Open()的输入。

另外，您尝试将sFileName与sourceWb进行比较，这是两种不同的数据类型，而是将sFileName与sourceWb.Name进行比较。

最后，假设工作簿将有一个名为"UTP"的工作表，如果代码不会崩溃。而是先检查工作表是否存在。查看https://stackoverflow.com/a/6040390/8520655了解详情。

请查看下面的例子; Public Sub myImport（） Dim sPathName As String，sFileName As String Dim sourceWb As Workbook，targetWb As Workbook

Set sourceWb = ActiveWorkbook
ActiveSheet.Cells(1, 1).Value = sourceWb.Name

sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)

Do While Len(sFileName) > 0
    ActiveSheet.Cells(1, 2).Value = sFileName
    If sFileName <> sourceWb.Name Then
        Set targetWb = Workbooks.Open(sPathName & sFileName)

        If SheetExists("UTP", targetWb) Then
            targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
        End If

        targetWb.Close
    End If

    sFileName = Dir
Loop
End Sub

Function SheetExists(SheetName As String, Optional wb As Excel.Workbook)
    Dim s As Excel.Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set s = wb.Sheets(SheetName)
    On Error GoTo 0
    SheetExists = Not s Is Nothing
End Function

如何使用VBA将特定工作表导入另一个工作簿

3 个答案: