Excel文件合并（基于宏）

Private Function SelectDir() As String
Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd    '用户按下的是操作按钮 (-1) 还是取消按钮 (0)
        If .Show = -1 Then
            SelectDir = .SelectedItems(1) & "\"
        End If
    End With
    Set fd = Nothing
End Function

Sub SearchFile()

Dim MyFolder, MyFile As String
Dim i As Integer

    MyFolder = SelectDir()
    Sheets("文件列表").Cells(1, 2) = MyFolder

    i = 1
    MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Sheets("文件列表").Cells(i, 1) = MyFile
        MyFile = Dir
        i = i + 1
    Loop

End Sub

Sub CombineSheets()

Dim MyFolder, MyFile, CurBook As String
Dim RowCount, FileCount, i As Integer

    With Sheets("文件列表")
         MyFolder = .Range("B1").Value
        FileCount = .[A65535].End(xlUp).Row
       .Range("B:B").ClearContents
        .Range("B1").Value = "合并出错"
    End With

    CurBook = ActiveWorkbook.Name

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    On Error GoTo ErrOpen
    For i = 1 To FileCount
        With Workbooks(CurBook)
            'RowCount = .Sheets("合并内容").[A65535].End(xlUp).Row
            'MyFile = .Sheets("文件列表").Cells(i, 1)
            'Application.Workbooks.Open (MyFolder & MyFile)
            'Workbooks(MyFile).Sheets(1).UsedRange.Copy
            '.Sheets("合并内容").Cells(RowCount + 1, 1).PasteSpecial
            '.Sheets("合并内容").Rows(RowCount + 1).EntireRow.Delete
            'Application.Workbooks(MyFile).Close savechanges:=False
            '.Sheets("文件列表").Cells(i, 2) = "合并完成"
         
           
            MyFile = .Sheets("文件列表").Cells(i, 1)
              'MsgBox i, vbInformation, "hcccc"
            Application.Workbooks.Open (MyFolder & MyFile)
              'MsgBox i, vbInformation, "haaaa"
            Workbooks(MyFile).Sheets(1).Columns("B:B").Copy
             ' MsgBox i, vbInformation, "hbbbb"
            .Sheets("合并内容").Columns(i).PasteSpecial              '黏贴
            Application.Workbooks(MyFile).Close savechanges:=False
            .Sheets("文件列表").Cells(i, 2) = "合并完成"
           
        End With
    Next i

ErrOpen:
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

Sub ClearFileList()
    With Sheets("文件列表")
        .Range("A:A").ClearContents
        .Range("B:B").ClearContents
    End With
End Sub

Sub ClearDetail()
    Sheets("合并内容").Cells.ClearContents
End Sub