Ez a makró a Collect.xls-be gyűjti az adatokat az E:\Valami\Akarmi\ könyvtárban lévő füzetek első lapjáról.

Biztosan át tudod írni, ha másik lapokról kellenek az adatok, vagy nem az A2 (címsort feltételezve) cellától kezdve minden adat, ami a lapon van.

Sub Adatgyujtes()    Const utvonal = "E:\Valami\Akarmi\"    Dim filenev As String        Application.ScreenUpdating = False    Application.DisplayAlerts = False        ChDir utvonal    filenev = Dir(utvonal & "*.xls", vbNormal)    Do        If filenev <> "." And filenev <> ".." And filenev <> "Collect.xls" Then            Workbooks.Open Filename:=filenev            Sheets(1).Select       'A Sheets(1) helyett add meg a másolandó füzetek lapjának a nevét            Range(Cells(2, 1), Selection.End(xlToRight)).Select            Range(Selection, Selection.End(xlDown)).Select            Selection.Copy                        ActiveWindow.Close            Cells(Range("A65536").End(xlUp).Row + 1, 1).Select            ActiveSheet.Paste        End If        filenev = Dir()    Loop Until filenev = ""        Application.DisplayAlerts = True    Application.ScreenUpdating = TrueEnd Sub