Array die Xte

Sub feldar() Dim dFeld As Variant Dim dFeldNeu() As Variant With Worksheets("ALT") dFeld = .Range("F2:F8").Value ReDim dFeldNeu(UBound(dFeld)) i = 0 For Each Zelle In dFeld .Range("P" & i + 2) = (Left(Zelle, 4)) i = i + 1 Next End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

…und wird wohl auch fktionieren, Jack,
aber du willst wohl erst ein neues DFeld als Vektor, dessen Elemente ebenfalls aus Vektoren bestehen, kreieren. Hierbei kann man so vorgehen, wie Ransi es zeigt, aber dadurch entsteht eine reguläre Matrix, deren Spalten bzw Zeilen nicht oW isoliert wdn können, weshalb ich dir hier mal eine Alternative zeige:

Sub feldar()
Const adQBer$ = "F2:F8", adZBer$ = "P2:Q8"    'QBer nur als Vektor!
Dim i As Long, dFeld, dFeldNeu(), Elem As Variant, Wsh As Worksheet
On Error Resume Next
Set Wsh = Worksheets("ALT")
dFeld = Wsh.Range(adQBer).Value
If IsError(LBound(dFeld, 2)) Or UBound(dFeld, 2)  LBound(dFeld, 2)) Then
dFeld = WorksheetFunction.Transpose(dFeld)
If UBound(dFeld, 2)  LBound(dFeld, 2)) Then GoTo ex
End If
ReDim dFeldNeu(UBound(dFeld, 1) - LBound(dFeld, 1), 0)
For Each Elem In dFeld
dFeldNeu(i, 0) = Array(Left(Elem, 4), Right(Elem, 4))
i = i + 1
Next Elem
Wsh.Range(adZBer) = dFeldNeu
ex: Set Wsh = Nothing
End Sub

Allerdings kannst du so nicht einen Vektor der linken und einen der rechten Zellwerte des Quellbereichs isolieren, um sie zB „auf einen Rutsch“ in getrennte (hier) Spalten zu speichern. Aber das Speichern in voneinander getrennte Zeilen wäre möglich, zB: Wsh.Range("P2:Q2") = dFeldNeu(0, 0) und Wsh.Range("S2:T2") = dFeldNeu(1, 0)… Für den erstgenannten Fall müssten die Teil-Arrays andersherum organisiert wdn. Also bspw so …

    …
ReDim dFeldNeu(1)
For Each Elem In dFeld
dFeldNeu(0) = dFeldNeu(0) & " " & Left(Elem, 4)
dFeldNeu(1) = dFeldNeu(1) & " " & Right(Elem, 4)
Next Elem
With WorksheetFunction
dFeldNeu(0) = .Transpose(Split(LTrim(dFeldNeu(0))))
dFeldNeu(1) = .Transpose(Split(LTrim(dFeldNeu(1))))
End With
Wsh.Range(adZBer) = dFeldNeu
…

Mit Wsh.Range("P2:P8") = dFeldNeu(0) könnte man so diese Zellen mit den linken Textteilen belegen und für die rechten zB Wsh.Range("T2:T8") = dFeldNeu(1) wählen.
Morrn, Luc :-?

…stehen geblieben, die beim nächsten Befehl mit übernommen wurde, Jack;
allerdings hat der Code auch erst jetzt den VBE „gesehen“… ;-)
Tja, das eigentliche Problem entsteht dadurch, dass quasi eine irreguläre Matrix erzeugt wird. In einer Fktsprozedur geht das mitunter trotzdem bei ungleicher Ausrichtung von Primär- und SekundärVektor(en) (habe so etwas stets für und mit UDFs entwickelt, die außerdem Elemente enthielten – ggf auch extern in der ZellFml –, die das dann garantierten); offensichtlich fktioniert das aber nicht in SubProzz bei DirektEintrag in einen Bereich. Hier müssten tatsächlich alle mit dFeldNeu(i, 0) = Array(Left(Elem, 4), Right(Elem, 4)) entstehenden HorizontalVektoren sofort in einen ZielTeilBereich eingetragen wdn, also bspw innerhalb der Schleife vor i-Erhöhung mit Wsh.Range(adZBer).Rows(2 * i + 1) = dFeldNeu(i, 0). Der rote Teil kann entfallen, wenn der Zielbereich lückenlos gefüllt wdn soll. Anderenfalls sollte noch die Konstante adZBer auf "P2:Q12" geändert wdn. Wsh.Range(adZBer) = dFeldNeu entfällt dann natürlich! In der anderen Variante dürften dann auch nur die beiden Einzelvektoren separat ausgebbar sein. Das kannst du ja mal testen.
Übrigens hatte ich hier noch eine Ergänzung zum anderen Thread geschrieben. Allerdings wird das wohl auch nur bei regulären Vektoren/Matrizen so fktionieren. Mit der UDF Collect sollte es aber immer klappen, wenn sie richtig argumentiert wird.
Gruß Luc :-?

Function TdFeld(ByVal Bezug) Dim i As Long, dFeld, dFeldNeu(), Elem As Variant On Error Resume Next If TypeName(Bezug) = "Range" Then dFeld = Bezug.Value Else dFeld = Bezug If IsError(LBound(dFeld, 2)) Or UBound(dFeld, 2) LBound(dFeld, 2) Then dFeld = WorksheetFunction.Transpose(dFeld) If UBound(dFeld, 2) LBound(dFeld, 2) Then TdFeld = CVErr(xlErrNull): Exit Function End If ReDim dFeldNeu(UBound(dFeld, 1) - LBound(dFeld, 1)) For Each Elem In dFeld dFeldNeu(i) = Array(Left(Elem, 4), Right(Elem, 4)): i = i + 1 Next Elem TdFeld = dFeldNeu End Function

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread