Array Redimensionierung schlägt fehl.
17.07.2017 13:55:51
Florian
Eins vorab, da es sich bei den hier verarbeiteten Dateien um den Export meiner Warenwirtschaftssysteme handelt, habe ich keine Dateien angehängt.
Wenn Hilfe nicht ohne Datei möglich ist, werde ich aber natürlich gerne eine entsprechende Datei mit ausgedachten Werten (im gleichen Format) zur Verfügung stellen.
Aber ich behaupte mal das geht auch ohne :)
Folgendes soll mein Makro tun:
Öffnen des Exports aus meinem Warenwirtschafssystem (Format.dbf) und hier bestimmte Spalten in zwei Dateien kopieren (die kopierten Spalten sind dabei in beiden Dateien andere).
Da es sich um zwei Warenwirtschafsysteme (mit identisch dem gleichen Namen) handelt, kann ich diese leider nicht gleichzeitig öffnen.
Vor habe ich folgendes:
Die benötigten Spalten in ein Array schreiben und dieses dann in meine beiden Dateien schreiben (in der Hoffnung, dass dies schneller geht, als ein direktes kopieren).
Mein Makro gibt mir bei der Redimensionierung (im Code gekennzeichnet) den Fehler:
"Index außerhalb des gültigen Bereiches".
Warum tirtt dieser Fehler auf?
Modul: MODExport
Option Explicit
'Makro zum Erstellen der Zoo Dateien
Public Sub ZooExport()
Dim strPfadLadenEho As String, strPfadAngelEho As String, strPfadZooDateien As String, _
strDateinameEho As String
Dim strZoo As String, strZoomitEk As String
Dim btEAN As Byte, btArtNr As Byte, btName1 As Byte, btName2 As Byte, btVK As Byte, btEK As _
Byte
Dim btVe As Byte, btNotiz As Byte, btMwst As Byte
Dim lngLetzteZeileZoo As Long, lngletzteZeileAngel As Long, lngletztezeile As Long
Dim i As Long, j As Long
Dim Datenarray() As String
TurnOff
'Festlegen der Variablen für Dateien
strPfadLadenEho = Left$(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "Ladeneho\"
strPfadAngelEho = Left$(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "Angeleho\"
strDateinameEho = "Artikel.dbf"
strPfadZooDateien = ThisWorkbook.Path & "\"
strZoo = "zoo.xlsm"
strZoomitEk = "zoomitEK.xlsm"
'Festlegen der Spaltennummern in Export Dateien
btEAN = 69
btArtNr = 1
btName1 = 2
btName2 = 3
btVK = 9
btEK = 6
btVe = 29
btNotiz = 18
btMwst = 10
'LadenEho
Workbooks.Open (strPfadLadenEho & strDateinameEho), ReadOnly:=True
With Workbooks(strDateinameEho).Worksheets("ARTIKEL")
lngLetzteZeileZoo = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim Datenarray(2 To lngLetzteZeileZoo, 1 To 10)
'befüllen des Arrays
For i = 2 To lngLetzteZeileZoo
Datenarray(i, 1) = .Cells(i, btEAN).Value
Datenarray(i, 2) = .Cells(i, btArtNr).Value
Datenarray(i, 4) = .Cells(i, btName1).Value
Datenarray(i, 5) = .Cells(i, btName2).Value
Datenarray(i, 6) = .Cells(i, btVK).Value
Datenarray(i, 7) = .Cells(i, btEK).Value
Datenarray(i, 8) = .Cells(i, btVe).Value
Datenarray(i, 9) = .Cells(i, btNotiz).Value
Datenarray(i, 10) = .Cells(i, btMwst).Value
Next i
End With
Workbooks(strDateinameEho).Close Savechanges:=False
'AngelEho
Workbooks.Open (strPfadAngelEho & strDateinameEho), ReadOnly:=True
With Workbooks(strDateinameEho).Worksheets("ARTIKEL")
lngletzteZeileAngel = .Cells(Rows.Count, 1).End(xlUp).Row
'Array vergrößern
ReDim Preserve Datenarray(2 To lngLetzteZeileZoo + lngletzteZeileAngel, 1 To 10)
j = lngLetzteZeileZoo
'befüllen des Arrays
For i = 2 To lngletzteZeileAngel
j = j + 1
Datenarray(j, 1) = .Cells(i, btEAN).Value
Datenarray(j, 2) = .Cells(i, btArtNr).Value
Datenarray(j, 3) = .Cells(i, btName1).Value
Datenarray(j, 4) = .Cells(i, btName2).Value
Datenarray(j, 5) = .Cells(i, btVK).Value
Datenarray(j, 7) = .Cells(i, btEK).Value
Datenarray(j, 8) = .Cells(i, btVe).Value
Datenarray(j, 9) = .Cells(i, btNotiz).Value
Datenarray(j, 10) = .Cells(i, btMwst).Value
Next i
End With
Workbooks(strDateinameEho).Close Savechanges:=False
'Öffnen der Zoo Liste
Workbooks.Open (strPfadZooDateien & strZoo)
With Workbooks(strZoo).Worksheets("Liste")
.Cells.ClearContents
.Range("A2") = "0"
.Range("B2") = "Scanner"
.Range("C2") = "EAN Code"
.Range("D2") = "Art. Nr."
.Range("E2") = "Name 1"
.Range("F2") = "Name 2"
.Range("G2") = "Preis"
.Range("H2") = "Menge"
.Range("C3:G" & UBound(Datenarray, 2)) = Datenarray
End With
TurnOn
End Sub
Option Explicit
'Funktionen aus
Public Sub TurnOff()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
'Funktionen ein
Public Sub TurnOn()
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub