Handling

Sub all workbook merging the current directory of all the work table ()

Dim MyPath, MyName, AWbName
Dim Wb As workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String

Application. ScreenUpdating=False
MyPath=ActiveWorkbook. Path
MyName=Dir (MyPath & amp; "" & amp; "*. XLS")
AWbName=ActiveWorkbook. Name
Num=0

The Do While MyName & lt;> "
"If MyName & lt;> AWbName Then
The Set Wb=Workbooks. Open (MyPath & amp; "" & amp; MyName)
Num=Num + 1
With Workbooks (1). ActiveSheet
Cells (Range (" B65536 "). The End (xlUp). Row + 2, 1)=Left (MyName, Len (MyName) - (4)
For G=1 To Sheets. Count
Wb. Sheets (G). UsedRange. Copy. Cells (the Range (" B65536 "). The End (xlUp). Row + 1, 1)
Next
WbN=WbN & amp; CRH (13) & amp; Wb. Name
Wb. Close False
End With
End the If
MyName=Dir
Loop
Range (" B1 "). Select
Application. ScreenUpdating=True

MsgBox "merged together" & amp; Num & amp; "A job under the thin all work table, as follows:" & amp; CRH (13) & amp; WbN vbInformation, "tip"

End Sub