Dataenkombination analysieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Daniel,
hier zwei Varianten. Die kurze verlässt sich etwas stärker darauf, dass die Quelldaten "passen".
Probier mal:


Option Explicit
Sub Dict_Pruefe_12()
Dim lngQ As Long, arQ, oDic As Object, strK As String, arI
Dim qq As Long, zz As Long, arA
With Sheets("Tabelle1")                         ' Quelldaten
lngQ = .Cells(1, 1).CurrentRegion.Rows.Count
arQ = .Cells(1, 1).Resize(lngQ, 3)              ' Sp. A:C
End With
Set oDic = CreateObject("Scripting.Dictionary")
For qq = 1 To lngQ
strK = arQ(qq, 1) & "x" & arQ(qq, 2)
oDic(strK) = oDic(strK) & arQ(qq, 3)
Next
With Sheets("Tabelle1")                ' Ausgabe in Zielblatt
arQ = oDic.Keys
arI = oDic.Items
zz = lngQ + 6
For qq = 0 To oDic.Count - 1
If Not (arI(qq) = "12" Or arI(qq) = "21") Then
arA = Split(arQ(qq), "x")
zz = zz + 1
.Cells(zz, 1) = 0 + arA(0)
.Cells(zz, 2) = 0 + arA(1)
.Cells(zz, 3) = 3 - arI(qq)
End If
Next qq
End With
End Sub
Sub Dict_Pruefe_12_lang()
Dim lngQ As Long, arQ, oDic As Object, strK As String, arI
Dim qq As Long, zz As Long, arA
With Sheets("Tabelle1")                         ' Quelldaten
lngQ = .Cells(1, 1).CurrentRegion.Rows.Count
arQ = .Cells(1, 1).Resize(lngQ, 3)              ' Sp. A:C
End With
Set oDic = CreateObject("Scripting.Dictionary")
For qq = 1 To lngQ
strK = arQ(qq, 1) & "x" & arQ(qq, 2)
If Trim(arQ(qq, 3)) = "" Then arQ(qq, 3) = "#"
If oDic.Exists(strK) Then           ' schon da?
oDic(strK) = oDic(strK) & arQ(qq, 3)
Else                                ' neuer Eintrag
oDic.Add strK, arQ(qq, 3)
End If
Next
With Sheets("Tabelle1")                ' Ausgabe in Zielblatt
arQ = oDic.Keys
arI = oDic.Items
zz = lngQ + 6
For qq = 0 To oDic.Count - 1
If Not (arI(qq) = "12" Or arI(qq) = "21") Then
arA = Split(arQ(qq), "x")
zz = zz + 1
.Cells(zz, 1) = 0 + arA(0)
.Cells(zz, 2) = 0 + arA(1)
If arI(qq) = "1" Or arI(qq) = "2" Then
.Cells(zz, 3) = 3 - arI(qq)
Else
.Cells(zz, 3) = "vorh: " & arI(qq)
End If
End If
Next qq
End With
End Sub

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Sub Suchen_nur_1oder2() Dim wks_Q As Worksheet, wks_Z As Worksheet Dim Zeile_Q As Long, Zeile_Z As Long Set wks_Q = ActiveSheet 'Quellltabelle Set wks_Z = ActiveSheet ' Zieltabelle Const Spalte_Formel As Long = 4 'Spalte D - Hilfsspalte zur Auswertung Application.ScreenUpdating = False With wks_Q 'letzte Zeile mit Daten ab Zelle A1 abwärts Zeile_Q = .Cells(1, 1).End(xlDown).Row 'Formel in Spalte D einfügen um Zeilen zu ermitteln, die nich mit 1 + 2 vorkommen With .Range(.Cells(1, Spalte_Formel), .Cells(Zeile_Q, Spalte_Formel)) .FormulaR1C1 = _ "=SUMPRODUCT((RC1=R1C1:R" & Zeile_Q & "C1)*(RC2=R1C2:R" _ & Zeile_Q & "C2)*((1=R1C3:R" & Zeile_Q & "C3)+(2=R1C3:R" _ & Zeile_Q & "C3)))=2" .Calculate 'Formeln durch Werte ersetzen .Value = .Value End With End With With wks_Z 'letzte Zeile mit Daten in Zieltabelle Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row End With 'Zeilen kopieren, die nich mit 1 + 2 vorkommen With wks_Q For Zeile_Q = 1 To Zeile_Q If .Cells(Zeile_Q, Spalte_Formel).Value = False Then Zeile_Z = Zeile_Z + 1 .Range(.Cells(Zeile_Q, 1), .Cells(Zeile_Q, 3)).Copy _ Destination:=wks_Z.Cells(Zeile_Z, 1) End If Next 'Spalte D wieder löschen .Columns(Spalte_Formel).Clear End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread