最后幾個萌寶了,，處理價格35元包郵了,，有需要的留言地址即可！

Private Sub 合并表_Click()

Dim Sh As Worksheet, MyName$, n%

Dim m As Long

Dim index As Long

Application.DisplayAlerts = False

Application.ScreenUpdating = False

If ThisWorkbook.Sheets.Count > 1 Then

If MsgBox('重新導(dǎo)入報表將刪除原來的表,，繼續(xù)嗎,？ ', 52, '警告') = 7 Then Exit Sub

End If

' 刪除當(dāng)前EXCEL的所有Sheet

On Error Resume Next

For Each Sh In Worksheets

If Sh.Name <> ActiveSheet.Name Then

Sh.Delete

End If

Next

n = 1

' =====================工作函數(shù)開始=====================

MyName = Dir(ThisWorkbook.Path & '\*.xls')

' 清除Sheet數(shù)據(jù)

Range('a2:b65536').ClearContents

' 循環(huán)遍歷

Do While MyName <> ''

If MyName <> ThisWorkbook.Name Then

Workbooks.Open ThisWorkbook.Path & '\' & MyName ' 如果不是當(dāng)前工作表,則進(jìn)行拷貝

strbox = ''

For index = 1 To Workbooks(MyName).Sheets.Count

m = 1

m = Workbooks(MyName).Sheets(index).UsedRange.SpecialCells(xlCellTypeLastCell).Row

Workbooks(MyName).Sheets(index).UsedRange.Copy

Workbooks(MyName).Sheets(index).Range('A2:Z' & m).Copy

With ThisWorkbook.Sheets(1)

.Paste .Cells(.Range('A65535').End(xlUp).Row + 1, 1)

End With

Next

Workbooks(MyName).Close

End If

MyName = Dir

Loop

Me.Activate

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

新建一個表，增加一個按鈕,，寫入上面的代碼試試吧,！