ReDim Preserve 2-dimensionaler Array
12.12.2016 11:11:01
Anton
ich versuche eine Textdatei Zeilenweise in einen Array einlesen und habe dafür folgenden Code:
Sub TXTEinlesen()
Dim arr() As String
Dim arr2() As Variant
Dim File As String
Dim z As Long
Dim row As Long
Dim I As Long
File = "C:\Users\Anton\Desktop\109950.txt"
Open File For Input As #1
I = 0
row = 0
z = 0
ReDim arr2(row, z)
Do Until EOF(1)
ReDim Preserve arr(I)
Line Input #1, arr(I)
arr = Split(Application.WorksheetFunction.Trim(arr(I)), " ")
I = I + 1
For z = LBound(arr) To UBound(arr)
arr2 = ReDimPreserve(arr2(), row, z)
arr2(row, z) = arr(z)
Next z
row = row + 1
Loop
Close #1
End Sub
'redim preserve both dimensions for a multidimension array *ONLY
Public Function ReDimPreserve(aArrayToPreserve As Variant, nNewFirstUBound As Long, _
nNewLastUBound As Long) As Variant
Dim nFirst As Long
Dim nLast As Long
Dim nOldFirstUBound As Long
Dim nOldLastUBound As Long
ReDimPreserve = False
'check if its in array first
If IsArray(aArrayToPreserve) Then
'create new array
ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)
'get old lBound/uBound
nOldFirstUBound = UBound(aArrayToPreserve, 1)
nOldLastUBound = UBound(aArrayToPreserve, 2)
'loop through first
For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound
'if its in range, then append to new array the same way
If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)
End If
Next
Next
'return the array redimmed
If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
End If
End Function
Die Funktion habe nach etwas Recherche bei Stackoverflow http://stackoverflow.com/questions/16369217/redim-preserve-to-a-multi-dimensional-array-in-visual-basic-6
gefundenSobald ein Zeilenwechsel stattfindet, werden die vorherigen Einträge überschrieben bzw. gelöscht. Ich habe viel Zeit damit verbracht, dass ganze zu verstehen. Leider komme ich nicht drauf. Kann mir von euch vielleicht wer einen Tipp geben?
Hier die Textfile: https://www.herber.de/bbs/user/109990.txt
Vielen Dank schon mal.
LG Anton