Так проверьте
[vba]Код
Sub Wowanich()
Const dir = "C:\test" 'Вставь правильный путь !!!
ChDir dir
Set fso = CreateObject("scripting.filesystemobject")
For Each ff In fso.getfolder(dir).Files
Set blank_cell = Cells(Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
If Right(ff.Name, 4) = ".dbf" Then
Set dbf = Workbooks.Open(Filename:=ff.Path, ReadOnly:=True)
dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Copy blank_cell.Offset(, 1)
blank_cell.Resize(dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Rows.Count) = Split(ff.Name & "_", "_")(0)
dbf.Close
End If
Next
End Sub
[/vba]