Excel-Datei wird immer zu groß

Sub Button1_Click()
Ordner_suchen
End Sub

Sub Ordner_suchen()

Dim dat

Dim ordner

Dim datein

Dim fso

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Ein Array mit 65536 Zeilen und 14 Spalten.

'Dient zur späteren Aufnahme der Werte.

Dim arr(2000, 14)

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Dim L As Long

Dim Z As Long

Dim WB

Dim dsplalert As Boolean

Dim cal

Dim scrup As Boolean

Dim ev As Boolean

'XXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Zum Beschleunigen des Makros

With Application

dsplalert = .DisplayAlerts

cal = .Calculation

scrup = .ScreenUpdating

ev = .EnableEvents

.DisplayAlerts = False              'Excelinterne Meldungen aus

.Calculation = xlCalculationManual  'Automatische Berechnung aus

.ScreenUpdating = False             'Bildschirm aktualisierung aus

.EnableEvents = False               'Makrostarts aus

End With

'XXXXXXXXXXXXXXXXXXXXXXXXXXX

'Überschriften ins Array schreiben

arr(L, 0) = "Spielzeug"

arr(L, 1) = "Anzahl"

arr(L, 2) = "unbenutzt"

arr(L, 3) = "fehlt"

arr(L, 4) = "zu viel"

arr(L, 5) = "falsches SpielzeugWKZ"

arr(L, 6) = "verschlissen"

arr(L, 7) = "augenscheinlich"

arr(L, 8) = "Reparatur"

arr(L, 9) = "Neu"

arr(L, 10) = "Schrott"

arr(L, 11) = "Kommentar"

L = L + 1

'XXXXXXXXXXXXXXXXXXXXXXXXXXX

'Dialog aufrufen

'Die innere IF-Then Konstruktion fängt "Abbrechen" in dem Dialog ab.

Set dat = Application.FileDialog(msoFileDialogFolderPicker)

With dat

.Title = "Such schön...."

.InitialFileName = "C:\" 'oder was auch immer

nochmal:

If .Show = -1 Then

ordner = .SelectedItems(1)

Else:

If MsgBox("Ordner auswählen vergessen." & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then

GoTo nochmal

Else:

GoTo raus

End If

End If

End With

'XXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Zugriff aus Dateisystem

Set fso = CreateObject("Scripting.filesystemobject")

Set datein = fso.getfolder(ordner)

'XXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Sucht jedes file in Ordner.

For Each WB In datein.Files

If WB.Name Like "*.xlsx" Then '

'XXXXXXXXXXXXXXXXXXXXXXXXXXXX

Workbooks.Open WB        'selbserklärend

'Jetzt wird die eigentliche Arbeit gemacht.

'z ist eine Variable über Zeilen.

'Sheets(1).Range("a65536").End(xlUp).Row ist die

'Zeilennummer der letzten beschriebenen Zelle in SpalteA (habe ich gewählt weil hier  _

die Werkzeuge gelistet sind)

'von WB.sheets(1).

For Z = 7 To Sheets(1).Range("a2000").End(xlUp).Row

arr(L, 0) = Sheets(1).Cells(Z, 1).Text

'schreibt den Wert aus cells(zeile=z,Spalte=1) ins Array an Position

'Zeile=7 und Spalte =1

arr(L, 1) = Sheets(1).Cells(Z, 2).Text

'schreibt den Wert aus cells(zeile=z,Spalte=2) ins Array an Position

'Zeile=7 und Spalte =2

arr(L, 2) = Sheets(1).Cells(Z, 3).Text

'schreibt den Wert aus cells(zeile=z,Spalte=3) ins Array an Position

'Zeile=7 und Spalte =3

arr(L, 3) = Sheets(1).Cells(Z, 4).Text

'schreibt den Wert aus cells(zeile=z,Spalte=4) ins Array an Position

'Zeile=7 und Spalte =4

arr(L, 4) = Sheets(1).Cells(Z, 5).Text

'schreibt den Wert aus cells(zeile=z,Spalte=5) ins Array an Position

'Zeile=7 und Spalte =5

arr(L, 5) = Sheets(1).Cells(Z, 6).Text

'schreibt den Wert aus cells(zeile=z,Spalte=6) ins Array an Position

'Zeile=7 und Spalte =6

arr(L, 6) = Sheets(1).Cells(Z, 7).Text

'schreibt den Wert aus cells(zeile=z,Spalte=7) ins Array an Position

'Zeile=7 und Spalte =7

arr(L, 7) = Sheets(1).Cells(Z, 8).Text

'schreibt den Wert aus cells(zeile=z,Spalte=8) ins Array an Position

'Zeile=7 und Spalte =8

arr(L, 8) = Sheets(1).Cells(Z, 9).Text

'schreibt den Wert aus cells(zeile=z,Spalte=9) ins Array an Position

'Zeile=7 und Spalte =9

arr(L, 9) = Sheets(1).Cells(Z, 10).Text

'schreibt den Wert aus cells(zeile=z,Spalte=10) ins Array an Position

'Zeile=7 und Spalte =10

arr(L, 10) = Sheets(1).Cells(Z, 11).Text

'schreibt den Wert aus cells(zeile=z,Spalte=11) ins Array an Position

'Zeile=7 und Spalte =11

arr(L, 11) = Sheets(1).Cells(Z, 12).Text

'schreibt den Wert aus cells(zeile=z,Spalte=12) ins Array an Position

'Zeile=7 und Spalte =12

L = L + 1

Next

Workbooks(WB.Name).Close False

'XXXXXXXXXXXXXXXXXXXXXXXXXXXX

End If

Next

Range("A:L") = arr 'Alle Werte auf einmal in die Tabelle übertragen

raus:

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Die Eingangs gemachten Einstellungen Rückgängig machen

With Application

.DisplayAlerts = dsplalert

.Calculation = cal

.ScreenUpdating = scrup

.EnableEvents = ev

End With

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

End Sub