Private Sub CommandButton5_Click()
On Error GoTo ErrorHandler
Const cWbExt = "*.xls"
Const cWshIndex = 1
Dim strPathSep As String
Dim strPathName As String
Dim strMyName As String
Dim strFilename As String
Dim wbIn As Excel.Workbook
Dim wshIn As Excel.Worksheet
Dim wshOut As Excel.Worksheet
Dim rngOut As Excel.Range

With Application
.ScreenUpdating = False
.DisplayAlerts = False
strPathSep = .PathSeparator
With .ThisWorkbook
strPathName = .Path
strMyName = .Name
With .Worksheets
Set wshOut = .Add(Before:=.Item(1))
End With
End With
End With

If Right$(strPathName, 1) <> strPathSep Then
strPathName = strPathName & strPathSep
End If

strPathName = strPathName
strFilename = Dir(strPathName & cWbExt, vbNormal)
Do While Len(strFilename)
If strFilename <> strMyName Then
'Debug.Print strFilename
Set wbIn = Workbooks.Open(strPathName & strFilename, ReadOnly:=True _
, AddToMru:=False)
'Debug.Print , wbIn.FullName
Set wshIn = wbIn.Worksheets.Item(cWshIndex)
'Debug.Print , , wshIn.Name
With wshOut.UsedRange
If .Rows.Count = 1 Then
Set rngOut = .Cells(1, 1)
Else
Set rngOut = .Resize(1, 1).Offset(.Rows.Count)
End If
With wshIn.Cells
.Range(.Item(1, 1) _
, .Find("*" _
, After:=.Cells(1, 1) _
, LookIn:=xlFormulas _
, LookAt:=xlPart _
, SearchOrder:=xlByRows _
, SearchDirection:=xlPrevious _
, MatchCase:=False) _
).Copy rngOut
End With
End With
wbIn.Close SaveChanges:=False
End If
strFilename = Dir
Loop

ExitProcedure:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
Set rngOut = Nothing
Set wshOut = Nothing
Set wshIn = Nothing
Set wbIn = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Description, vbCritical
Resume ExitProcedure
End Sub



-----------------
Questo codice lo uso tutto in un command button...