Wegen LeerMengen nun noch Version1.2, ...
15.07.2016 02:59:38
Luc:-?
…Michael,
denn Vs1.1 hat hier Schwächen gezeigt, die nun hoffentlich bereinigt sind, so dass das die auf absehbare Zeit (ggf auch nur vorläufig ;-]) letzte Version* sein dürfte. Hier muss auch nicht mehr extern MTRANS verwendet wdn, wenn ein erzeugter horizontaler Vektor als vertikaler ausgegeben wdn soll (AutoErkennung eingebaut).
* Interessant wäre ggf noch eine eingebaute Ausgabe des Ganzen als Text in MatrixKonsttForm, aber das kann auch die aktuelle Version1.5 von VJoin (VSplit aktVs1.4, beide bisher unveröffentlicht).
Die 3 verwendeten Enumerationen sind wieder den Postings der vorherigen Versionen zu entnehmen!
Rem Bildet 1 DatenMenge aus 2en n.5 praxisrelevanten OperatTypen
' Arg1/2: 1./2.Menge (ZBereichsBezugs- oder Datenfeld-VEKTOR),
' beide dürf LeerMengg sein, leere Elementt wdn b.Arg30), fehlt/0 keine Elemtt entfern;
' Arg5: wahr/±1 horiz ErgebnVektor (wird ggf automat transpon,
' wenn mehr Zeilen ausgewählt wdn), fehlt/falsch/0 vert Vektor
' aus ElemttPaaren bd Mengen (1 Elem ggf leer, nur Arg3=0/±2);
' Arg6: fehlt/leer LeerMg|LeerWert=Zch12|leer (idR 0 gezeigt),
' 0 LM|LW=Ø|#NV, 1 LM|LW=LeerText m.Lg|o.Lg, -1 LM|LW=LToL|-0.
' Achtung! Vwendet intern WshFct Transpose (MTRANS, ElemttAnz-
' Limitierung!) u.Enumeratt cxSetType, cxTriState, xlTriState!
' Hinw ANZAHL-Ermittl: -0 nicht vwend, ANZ~2 zählt stets alle!
' Vs1.2 -LSr:CyWorXxl -cd:20160711 -1pub:h20160713-15 -lupd:20160714n
Function DataSet(Menge1, Menge2, Optional ByVal ErgMengTyp As cxSetType, Optional _
ByVal nurUnikate As xlTriState, Optional ByVal kPaare As Boolean, _
Optional ByVal LeerErsatz As cxTriState = cxAsUsed)
Const ucLeerMalt1 As Long = 0, ucLeerMalt2 As Long = 65279, _
ucLeerMdef As Long = 12, ucLeerMsym As Long = 8709
Dim ik As Integer, ix As Long, iz As Long, erg, ersZ(1) As Variant, _
M1, M2, tEVgl, tM, xEl As Variant, wf As WorksheetFunction
On Error Resume Next: Set wf = WorksheetFunction
If LeerErsatz cxAsUsed Then LeerErsatz = LeerErsatz Mod 2
ersZ(0) = ChrW(Array(ucLeerMdef, ucLeerMalt1, ucLeerMsym, ucLeerMalt2)(LeerErsatz + 2))
ersZ(1) = Array(Empty, -CDbl(0), CVErr(xlErrNA), "")(LeerErsatz + 2)
nurUnikate = nurUnikate Mod 2: ErgMengTyp = ErgMengTyp Mod 3
If nurUnikate = xlTrue And ErgMengTyp = cxCollect Then ErgMengTyp = cxUnite
kPaare = CBool(ErgMengTyp Mod 2) Or kPaare
If IsArray(Menge1) Then
If TypeName(Menge1) = "Range" Then _
M1 = wf.Transpose(wf.Transpose(Menge1)) Else M1 = Menge1
If IsError(LBound(M1, 2)) Then Else M1 = wf.Transpose(M1)
If IsError(LBound(M1, 2)) Then Else DataSet = CVErr(xlErrRef): GoTo xx
If CBool(nurUnikate) Then
ix = LBound(M1): ReDim tM(UBound(M1) - ix): ik = Abs(ix = 0)
For Each xEl In M1
If wf.Match(xEl, M1, 0) = ix + ik Then tM(iz) = xEl: iz = iz + 1
ix = ix + 1
Next xEl
ReDim Preserve tM(iz - (2 * iz) \ (iz + 1)): M1 = tM: iz = 0
Else: ReDim Preserve M1(UBound(M1) - LBound(M1))
End If
Else: M1 = Array(Menge1)
End If
If IsArray(Menge2) Then
If TypeName(Menge2) = "Range" Then _
M2 = wf.Transpose(wf.Transpose(Menge2)) Else M2 = Menge2
If IsError(LBound(M2, 2)) Then Else M2 = wf.Transpose(M2)
If IsError(LBound(M2, 2)) Then Else DataSet = CVErr(xlErrRef): GoTo xx
If CBool(nurUnikate) Then
ix = LBound(M2): ReDim tM(UBound(M2) - ix): ik = Abs(ix = 0)
For Each xEl In M2
If wf.Match(xEl, M2, 0) = ix + ik Then tM(iz) = xEl: iz = iz + 1
ix = ix + 1
Next xEl
ReDim Preserve tM(iz - (2 * iz) \ (iz + 1)): M2 = tM: ix = 0: iz = 0
Else: ReDim Preserve M2(UBound(M2) - LBound(M2))
End If
Else: M2 = Array(Menge2)
End If
ReDim erg(IIf(kPaare, UBound(M1) + UBound(M2) + 1, wf.Max(UBound(M1), UBound(M2))))
For Each xEl In M1
If IsEmpty(xEl) Then
If ErgMengTyp = cxCollect Then xEl = ersZ(1) Else GoTo nx
End If
Select Case ErgMengTyp
Case cxSymDiff, cxDiff
If IsError(wf.Match(xEl, M2, 0)) Then erg(ix) = xEl: ix = ix + 1
Case cxUnite, cxCollect
erg(ix) = xEl: ix = ix + 1
Case cxInterSect
If IsError(wf.Match(xEl, M2, 0)) Then Else erg(ix) = xEl: ix = ix + 1
End Select
nx: Next xEl
If ErgMengTyp Mod 2 = 0 Then
If kPaare Then iz = ix
For Each xEl In M2
If IsEmpty(xEl) Then
If ErgMengTyp = cxCollect Then xEl = ersZ(1) Else GoTo nz
End If
Select Case ErgMengTyp
Case cxSymDiff, cxUnite
If IsError(wf.Match(xEl, M1, 0)) Then
If kPaare Then erg(iz) = xEl Else erg(iz) = Array(erg(iz), xEl)
iz = iz + 1
End If
Case cxCollect
If kPaare Then erg(iz) = xEl Else erg(iz) = Array(erg(iz), xEl)
iz = iz + 1
End Select
nz: Next xEl
If wf.Max(ix, iz) > 0 Then
ReDim Preserve erg(wf.Max(ix, iz) - 1)
Else: ReDim Preserve erg(0)
End If
If Not kPaare Then
If ix > iz Then
For iz = iz To ix - 1
erg(iz) = Array(erg(iz), ersZ(1))
Next iz
ElseIf LeerErsatz > cxAsUsed Then
If ix cxAsUsed Then
If iz = 0 Then erg(0) = ersZ(1)
End If
ElseIf ix > 0 Then
ReDim Preserve erg(ix - 1)
Else: erg = ersZ(1)
End If
If IsArray(erg) Then
If IsArray(erg(0)) Then
If IsError(erg(0)(0) = erg(0)(1)) Then
DataSet = erg
ElseIf erg(0)(0) = erg(0)(1) Then
tEVgl = erg(0)(0): GoTo vx
Else: DataSet = erg
End If
Else: tEVgl = erg(0): GoTo vx
End If
Else: tEVgl = erg
vx: Select Case LeerErsatz
Case cxAsUsed
If IsEmpty(tEVgl) Then DataSet = ersZ(0) Else DataSet = erg
Case cxTrue
If tEVgl = ersZ(1) Then DataSet = ersZ(0) Else DataSet = erg
Case cxFalse
If wf.IsNA(tEVgl) Then DataSet = ersZ(0) Else DataSet = erg
Case cxCTrue
If tEVgl = ersZ(1) Then DataSet = ersZ(0) Else DataSet = erg
End Select
End If
ex: If IsError(DataSet) Then GoTo xx
With Application
If kPaare And .ThisCell.HasArray Then
If .Caller.Rows.Count > 1 Then DataSet = wf.Transpose(DataSet)
End If
End With
xx: erg = Empty: M1 = Empty: M2 = Empty: tM = Empty: Set wf = Nothing
End Function
Morrn, Luc :-?