So, iss'n paar Abende später geworden, ...
08.08.2014 16:29:05
Luc:-?
…Robert,
weil ich unbedingt erst noch etwas Komplexeres fertigstellen wollte (s. OlXl-CP-Forum).
Wenn ich deinen PgmAuszug richtig interpretiere, trägst du die gefundenen Werte mehrfach ein. Davon geht jetzt auch mein Vorschlag aus, wobei auch die 1.Zeile des ZielBlattes kopiert wird und die ergänzten Angaben dann alle auf 1× in das wert-gelöschte ZielBlatt geschrieben wdn. Teste meinen Vorschlag also erst an einer Kopie. Mir war dein Vorhaben zu spezifisch, als dass ich das neue Pgm testen konnte und wollte. Es sollte ja wohl auch nur ein Bsp sein.
Was die Arrays betrifft, habe ich den 2.Typ gewählt → Variant mit einem Array, wobei ZBer dann konkret ein senkrechter, 1dimensionaler Vektor ist, dessen Elemente von horizontalen, 1dimensionalen Vektoren gebildet wdn. Dazu die folgd Anmerkung:
In Xl ist jeder Bereich stets 2dimensional, auch ein ZeilenVektor. In VBA sind nur ZeilenVektoren idR 1dimensional, SpaltenVektoren fast immer 2dimensional. Nur in der hier vorliegenden Form ist auch der SpaltenVektor 1dimensional. Wenn sowohl der HptVektor als auch die ElementeVektoren horizontal wären, könnte das Datenfeld nicht ohne Transformierung auf einen XlZellBereich abgebildet wdn.
Const txSuBeg$ = "WERTXYZ"
Dim ix As Long, iz As Long, zR As Long, CBox(1 To 3) As Long, _
QBer, ZBer As Variant, urC1 As Range, xR As Range
On Error GoTo fx
ReDim ZBer(Output.UsedRange.Rows.Count - 1), QBer(3)
With WorksheetFunction
QBer(0) = .Transpose(Mapping.Columns(20))
QBer(1) = .Transpose(Mapping.Columns(31)): CBox(1) = Me.ColumnBox1 'Customer
QBer(2) = .Transpose(Mapping.Columns(33)): CBox(2) = Me.ColumnBox2 'Material
QBer(3) = .Transpose(Mapping.Columns(49)): CBox(3) = Me.ColumnBox3 'ProductFamily
For Each xR In Output.UsedRange.Rows
If CBool(.CountA) Then ZBer(iz) = .Transpose(.Transpose(xR)): iz = iz + 1
Next xR
On Error Resume Next: zR = .Match(txSuBeg, QBer(0), 0): On Error GoTo fx
If CBool(zR) Then
For iz = 1 To UBound(ZBer)
For ix = 1 To 3
If CBox(ix) "" Then ZBer(iz)(CBox(ix)) = QBer(ix)(zR)
Next ix
Next iz
End If
End With
With Output.UsedRange
Set urC1 = .Cells(1): .ClearContents
End With
urC1.Resize(UBound(ZBer) + 1, UBound(ZBer(0))) = ZBer
fx: If CBool(Err.Number) Then MsgBox Err.Description, vbCritical, _
"Interner Fehler " & Err.Number: Set xR = Nothing
ex: Set urC1 = Nothing
Viel Spaß + schöWE, Luc :-?