将特定命名的工作表从文件夹中的所有文件复制到工作簿

Question

我正在尝试将不同工作簿中的特定命名工作表复制到主工作簿。

我不确定我对“IF”语句的理解。如果我在endif 上使用断点逐步运行我的代码，我会得到我想要的结果，即我文件夹中每个文件的每个 IF 语句中命名的每个工作表，但是如果我正常运行它，我的代码将只通过第一个 IF 语句然后切换文件。我将获得文件夹中每个文件的第一个工作表。

有人可以建议我解决这个问题吗？

顺便说一句，我知道我可以在一个 FOR 循环中执行 IF 语句，我只是在处理循环之前尝试一步一步地遵循它。我还尝试设置等待时间，以防错误出现在打开文件或其他内容的时间，但看起来不像。

Sub Import_Files()

Dim MyFolder As String, MyFile As String

With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .Show
   MyFolder = .SelectedItems(1)
   Err.Clear
End With

'stops screen updating, calculations, events, and status bar updates to help code run faster
'It'll be opening and closing many files so this will prevent the screen from displaying that

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

'This section will loop through and open each file in the folder selected
'and then close that file before opening the next file

Set sThisBk = ActiveWorkbook
MyFile = Dir(MyFolder & "\", vbNormal)

Do While MyFile <> ""
    DoEvents
    'On Error GoTo 0
    Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
    'Application.Wait (Now + TimeValue("0:00:15"))
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If SheetExists("ANALYSE E 000002") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000002")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000003") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000003")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000004") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000004")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000005") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000005")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000006") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000006")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000007") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000007")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000008") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000008")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000009") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000009")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000010") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000010")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000011") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000011")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE E 000012") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE E 000012")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000002") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000002")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000003") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000003")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000004") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000004")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000005") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000005")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000006") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000006")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000007") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000007")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000008") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000008")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000009") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000009")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000010") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000010")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000011") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000011")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    If SheetExists("ANALYSE F30 000012") Then
        Set wsSht = Workbooks(MyFile).Sheets("ANALYSE F30 000012")
        wsSht.Copy Before:=sThisBk.Sheets("ENDOFFILE")
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '0
    Workbooks(MyFile).Close SaveChanges:=False
    MyFile = Dir
Loop

'turns settings back on that was turned off before looping folders

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationManual

End Sub


Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function

Answer 1

主要问题是您的函数SheetExists 不知道它需要在哪个工作簿中搜索。因此它需要一个参数供工作簿查看。

Private Function SheetExists(ByVal SheetName As String, Optional InWorkbook As Workbook) As Boolean
    Dim sht As Object

    If InWorkbook Is Nothing Then Set InWorkbook = ThisWorkbook 'default to ThisWorkbook 

    On Error Resume Next
    Set sht = InWorkbook.Sheets(SheetName)
    SheetExists = Not sht Is Nothing
    On Error Goto 0 'either this or Err.Clear is needed
End Function

然后我建议定义一个应该复制的工作表名称列表以便能够使用循环：

Dim ListOfSheetNames As Variant
ListOfSheetNames = Array("ANALYSE E 000002", "ANALYSE E 000003") 'add more sheet names here

然后将您打开的工作簿设置为一个变量以便于访问：

Dim OpenedWorkbook As Workbook
Set OpenedWorkbook = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)

最后遍历您的工作表名称列表，测试工作表名称是否存在于您打开的工作簿中并将其复制到ThisWorkbook（这是运行此代码的工作簿）。

Dim SheetName As Variant
For Each SheetName In ListOfSheetNames 'loop through all sheet names in the list
    If SheetExists(SheetName, OpenedWorkbook) Then 'test if sheet name exists in the opened workbook
        OpenedWorkbook.Sheets(SheetName).Copy Before:=ThisWorkbook.Sheets("ENDOFFILE")
    End If
Next SheetName

最后你可以用

关闭你打开的工作簿

OpenedWorkbook.Close SaveChanges:=False