Például. Én szeretek csak annyi sort kimásolni az alapfájlból amennyiben értékes adat van (vizsgáljuk például azt hogy mi az utolsó sor), ez itt lent annyiban egyszerűbb hogy mindenképpen 200 sornyi adatot másol. Az "első munkalap" nem mindig az első munkalap ezért érdemes lenne inkább névre hivatkozni.

 

 

Sub CrDb()

Dim FSO As Scripting.FileSystemObject, folder As Scripting.folder, file As Scripting.file, wb As Workbook

'szükséges referencia a "Microsoft Scripting Runtime"-hoz. VBA-ban Tools - References alatt

Dim directory As String

Dim thisWB, tempWB As String

Dim dbSh As String

Dim i As Long

 

Application.ScreenUpdating = False 'képernyõfrissítés kikapcsolása

 

Workbooks.Add 'adatbázis új munkafüzetben, ezt majd lementheted MIND.xls néven v. akárhogy máshogy

thisWB = ActiveWorkbook.Name

dbSh = ActiveSheet.Name

i = 1

 

    directory = "d:\PersonalData\Test" 'az alkönyvtár ahol a fájlok vannak.

 

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set folder = FSO.GetFolder(directory)

 

    For Each file In folder.Files

 

        Application.DisplayAlerts = False 'windows üzenetek kikapcsolása

        Workbooks.Open file

        tempWB = ActiveWorkbook.Name

        Worksheets(1).Activate 'az elsõ munkalap ahol az adatok vannak

        Range("A1:J200").Select 'az a tartomány ahol az adatok vannak

        Selection.Copy

 

        Workbooks(thisWB).Worksheets(dbSh).Activate

        Cells(i, 1).Select 'adatok bemásolása az adatbázisba

        ActiveSheet.Paste

        i = i + 200 'következõ adathalmaz 200 sorral késõbb másolódik

        Workbooks(tempWB).Activate

        ActiveWorkbook.Saved = True

        ActiveWorkbook.Close 'becsukjuk az alapfájlt

        Application.StatusBar = tempWB & " kész" 'statusbar frissítése, hol tart a program

 

    Next file

End Sub