Excel VBA-打开另一个工作簿，并检查表是否存在并合并

Question

我正在尝试为标题中所述的问题找到解决方案。让我解释一下。我试图通过选择文件夹来合并多个纸。我通过使用以下代码来实现这一目标：

Option Explicit
Public strPath As String
Public Type SELECTINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As SELECTINFO) As Long
Function SelectFolder(Optional Msg) As String
Dim sInfo As SELECTINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
sInfo.pidlRoot = 0&
If IsMissing(Msg) Then
    sInfo.lpszTitle = "Select your folder."
Else
    sInfo.lpszTitle = Msg
End If
sInfo.ulFlags = &H1
x = SHBrowseForFolder(sInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
    pos = InStr(path, Chr$(0))
    SelectFolder = Left(path, pos - 1)
Else
    SelectFolder = ""
End If
End Function
"Merging Part"
Sub MergeExcels()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
RowofCopySheet = 1 
ThisWB = ActiveWorkbook.Name
path = SelectFolder("Select a folder containing Excel files you want to merge")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
    If Not Filename = ThisWB Then
        Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
        Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
        Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
        CopyRng.Copy Dest
        Wkb.Close False
    End If
    Filename = Dir()
Loop
Range("A1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Files Merged!"
End Sub

我什至设法调整了上述代码以合并目标工作簿的第二张纸。

但是，在我的新任务中，我必须检查" data2"表的存在。如果存在，我想将所有这些床单合并到我当前的工作簿中。

谢谢。

Answer 1

尝试以下：

'Merging Part
Sub MergeExcels()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, wbSource As Workbook, shtDest As Worksheet, shtSource As Worksheet
Dim Filename As String
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
RowofCopySheet = 1
ThisWB = ThisWorkbook.Name 'ActiveWorkbook.Name
path = SelectFolder("Select a folder containing Excel files you want to merge")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ThisWorkbook.Sheets(1)
Filename = Dir(path & "*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
    If Not Filename = ThisWB Then
        Set wbSource = Workbooks.Open(Filename:=path & "" & Filename)
        For Each shtSource In wbSource.Worksheets ' loop through all worksheets
           If shtSource.Name = "Data2" Then 'if ther's a worksheet named "Data2"
                'Set CopyRng = shtSource.Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                Set CopyRng = shtSource.UsedRange ' copy the used Range / Filled Range
                Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                CopyRng.Copy Dest
           End If
        Next
        wbSource.Close False ' close the sourceworkbook
    End If
    Filename = Dir()
Loop
shtDest.Range("A1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Files Merged!"
End Sub