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

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

1 个答案: