So, wie nachfolgend aufgelöst, schon, ...
16.09.2013 02:53:08
Luc:-?
…Markus;
ansonsten könntest du es ja mal mit der vbFkt/Methode Evaluate versuchen, wobei die Fml aber unbedingt in US-OriginalNotation als Text angegeben wdn muss, also ungefähr so:
Evaluate("INDEX(Q!A1:K7,MATCH(Z!E9&E11&E12,Q!B1:B7&C1:C7&D1:D7,0),MATCH(Z!B14:B23,Q!A1:K1,0))")
Für Q! (und ggf Z!) die Dateipfade/-namen+TabNamen einsetzen (bzw das weglassen)!
Fürchte nur, dass die Fml etwas zu komplex sein könnte. Außerdem ist nicht ganz klar, wo die Fml wirklich steht. Doch nicht in B14ff, denn da sollte eigentlich der SpaltenVglswert stehen → davon bin ich auch im Folgenden ausgegangen!
Pgm setzt in dieser Form die geöffnete QuellDatei voraus:
Sub …()
Const adQrelBer$ = "A1:K7", adQvglZlBer$ = "B1:D7", adZvglZlBer$ = "E9,E11:E12", _
adQvglSpBer$ = "A1:K1", adZvglSpBer$ = "B14:B23", _
naQMap$ = "Abfrage.xls", naQTab$ = "Tabelle1"
Dim six As Long, zix As Long, _
avQrelBer, avQvglSpBer, avQvglZlBer, avZvglSpBer, avZvglZlBer, xEl As Variant, _
QrelBer As Range, QvglSpBer As Range, ZvglSpBer As Range, _
QvglZlBer As Range, ZvglZlBer As Range, xRo As Range
On Error GoTo fx
With Workbooks(naQMap).Sheets(naQTab)
Set QrelBer = .Range(adQrelBer)
Set QvglSpBer = .Range(adQvglSpBer): Set QvglZlBer = .Range(adQvglZlBer))
End With
Set ZvglSpBer = Range(adQvglSpWrt): Set ZvglZlBer = Range(adQvglZlWrt
Redim avQvglZlBer(QvglZlBer.Rows.Count - 1)
With WorksheetFunction
avQrelBer = .Transpose(.Transpose(QrelBer))
avQvglSpBer = .Transpose(.Transpose(QvglSpBer))
avZvglSpBer = .Transpose(.Transpose(ZvglSpBer))
For Each xRo In QvglZlBer.Rows
avQvglZlBer(zix) = Join(.Transpose(.Transpose(xRo)), ""): zix = zix + 1
Next xRo
With ZvglZlBer
avZvglZlBer = .Areas(1).Cells(1)
With .Areas(2)
avZvglZlBer = avZvglZlBer & .Cells(1) & .Cells(2)
End With
End With
On Error Resume Next
zix = 0: zix = .Match(avZvglZlBer, avQvglZlBer, 0)
On Error GoTo fx
If zix = 0 Then Err.Raise xlErrNA
On Error Resume Next
For Each xEl In avZvglSpBer
six = .Match(xEl, avQvglSpBer, 0)
If CBool(six) Then Exit For
Next xEl
End With
On Error GoTo fx
If IsEmpty(xEl) Then Err.Raise xlErrNA
Debug.Print avQrelBer(zix, six): Goto ex
fx: If Err.Number = xlErrNA Then
Debug.Print "Wert(" & zix & "," & six & ") nicht vorhanden!"
Else: Debug.Print Err.Description
End If
ex: Set QrelBer = Nothing: Set QvglSpBer = Nothing: Set ZvglSpBer = Nothing
Set QvglZlBer = Nothing: Set ZvglZlBer = Nothing
End Sub
Bitte alle Bereichs- und VariantNamen überprüfen (falls ich etwas vertauscht haben sollte)! Hoffe, dass diese Direktpgmmrg aus dem Stegreif fktioniert! Bessere Performance als mit der Fml kann ich aber nicht garantieren, obwohl die vorliegende Vorgehensweise wahrscheinlich schon ziemlich optimal sein dürfte.
Viel Glück! Gruß Luc :-?