☰

Reguläres Modul

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba microsoft-excel-2007 macros
Reguläres Modul

Der folgende VBA-Code extrahiert die am häufigsten vorkommenden sich wiederholenden Paare und Tripletts aus einem gegebenen Datensatz, der 6 Datenspalten (A1, B1, C1, D1, E1, F1) erfordert, und zeigt ihre Anzahl an Vorkommen an. Ich möchte, dass dieser Code nur Quadruplets aus einem Datensatz extrahiert, der 22 Datenspalten (A1, B1, C1, ... U1, V1) enthält, und die Anzahl ihrer Vorkommen auf ähnliche Weise anzeigt. Ich bin nicht sicher, ob das zu viele Daten für Excel sind.

Sub MostCommonPairAndTriplet()
Dim rng As Range
Dim c As Range
Dim strPair As String
Dim strTriplet As String
Dim wsResult As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim i As Integer
Dim j As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

If Not rng Is Nothing Then

'Get the result worksheet
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
Set wsResult = ActiveWorkbook.Worksheets.Add
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If
'column labels
With wsResult
.Range("B1").Value = "Value1"
.Range("C1").Value = "Value2"
.Range("D1").Value = "Count"
.Range("F1").Value = "Value1"
.Range("G1").Value = "Value2"
.Range("H1").Value = "Value3"
.Range("I1").Value = "Count"
End With
On Error GoTo 0

'Find Pairs
lRow = 2
For Each c In rng
    If c.Column <= 5 Then
        For i = 1 To 6 - c.Column
            strPair = c.Value & "_" & c.Offset(0, i).Value

            On Error Resume Next
            lRow2 = Application.WorksheetFunction.Match(strPair, wsResult.Range("A:A"), False)
            If Err.Number > 0 Then
                wsResult.Range("A" & lRow).Value = strPair
                wsResult.Range("B" & lRow).Value = c.Value
                wsResult.Range("C" & lRow).Value = c.Offset(0, i).Value
                wsResult.Range("D" & lRow).Value = 1
                lRow = lRow + 1
            Else
                wsResult.Range("D" & lRow2).Value = wsResult.Range("D" & lRow2).Value + 1
            End If
            On Error GoTo 0
        Next i
    End If
Next c

'Find Triplets
lRow = 2
For Each c In rng
    If c.Column <= 5 Then
        For i = 1 To 6 - c.Column
            For j = 1 To 6 - c.Offset(0, i).Column
                strTriplet = c.Value & "_" & c.Offset(0, i).Value & "_" & c.Offset(0, i + j).Value

                On Error Resume Next
                lRow2 = Application.WorksheetFunction.Match(strTriplet, wsResult.Range("E:E"), False)
                If Err.Number > 0 Then
                    wsResult.Range("E" & lRow).Value = strTriplet
                    wsResult.Range("F" & lRow).Value = c.Value
                    wsResult.Range("G" & lRow).Value = c.Offset(0, i).Value
                    wsResult.Range("H" & lRow).Value = c.Offset(0, i + j).Value
                    wsResult.Range("I" & lRow).Value = 1
                    lRow = lRow + 1
                Else
                    wsResult.Range("I" & lRow2).Value = wsResult.Range("I" & lRow2).Value + 1
                End If
                On Error GoTo 0
            Next j
        Next i
    End If
Next c
End If

wsResult.Columns("E").Clear
wsResult.Columns("A").Delete

'Sort the pairs
With wsResult
.Columns("A:C").Sort Key1:=.Range("C2"), Order1:=xlDescending
.Columns("E:H").Sort Key1:=.Range("H2"), Order1:=xlDescending
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Antwort1

Aufgrund der großen Anzahl möglicher Quads bei 22 Zellen pro Reihe schlage ich einen anderen Ansatz vor als den, den Sie für Doppel- und Dreiergruppen verwendet haben.

Ich würde ein benutzerdefiniertes Objekt (Klasse) erstellen, das Informationen zum Inhalt des Quads und eine Anzahl enthält. (Ich habe auch eine Methode zum Erstellen eines Arrays der Quad-Elemente eingefügt.) Dann würde ich die Quads in einem Wörterbuchobjekt sammeln – im Code unten habe ich Early-Binding verwendet (einen Verweis unter festlegen, Tools --> Referencesaber Microsoft Scripting Runtimewenn dies verteilt werden soll, sollten Sie wahrscheinlich zu Late-Binding wechseln.

Beim Sammeln der Quads nach der ersten Zeile können wir das Wörterbuch verwenden, um zu testen, ob das Quad bereits vorhanden ist. Wenn dies der Fall ist, addieren wir eins zur Anzahl. Wenn nicht, speichern wir es als neues Quad.

Die Größe des Bereichs wird bestimmt, indem nach der letzten Zeile in Spalte A und der letzten Spalte in Zeile 1 gesucht wird. Dabei wird davon ausgegangen, dass Ihre Daten in A1 beginnen (wie Sie es auf Ihrem Arbeitsblatt zeigen) und dass keine Kopfzeilen vorhanden sind. Wenn dies nicht der Fall ist, müssen Sie möglicherweise einige Anpassungen vornehmen.

Außerdem wird davon ausgegangen, dass die Einträge in jeder Zeile sortiert sind. Wenn dies nicht der Fall ist, müssen Sie vor dem Generieren des Quads eine Sortierroutine hinzufügen.

BEARBEITEN: Beachten Sie, dass die Routine abstürzt (mit einem 1004-Fehler), wenn Ihre gewünschte Ausgabe aufgrund der Zeilenbegrenzung von Excel mehr als 2^20 Quads enthält. Es gibt mindestens zwei Möglichkeiten, damit umzugehen:

  • Erhöhen Sie den Schwellenwert, um nur Quads auszugeben, deren Anzahl 2, 3 oder was auch immer erforderlich ist, um in einen einzelnen Spaltensatz zu passen, beträgt (wahrscheinlich die einfachste Methode).

  • Ändern Sie die Ausgaberoutine, um die Ausgabe auf mehrere Spaltensätze zu verteilen.

Klassenmodul

Denken Sie daran, dies in cQuad umzubenennen.

Option Explicit
'Rename cQuad
Private pQ1 As Long
Private pQ2 As Long
Private pQ3 As Long
Private pQ4 As Long
Private pCnt As Long
Private pArr As Variant

Public Property Get Q1() As Long
    Q1 = pQ1
End Property
Public Property Let Q1(Value As Long)
    pQ1 = Value
End Property

Public Property Get Q2() As Long
    Q2 = pQ2
End Property
Public Property Let Q2(Value As Long)
    pQ2 = Value
End Property

Public Property Get Q3() As Long
    Q3 = pQ3
End Property
Public Property Let Q3(Value As Long)
    pQ3 = Value
End Property

Public Property Get Q4() As Long
    Q4 = pQ4
End Property
Public Property Let Q4(Value As Long)
    pQ4 = Value
End Property

Public Property Get Arr() As Variant
    Dim V(1 To 4)
        V(1) = Me.Q1
        V(2) = Me.Q2
        V(3) = Me.Q3
        V(4) = Me.Q4
    Arr = V
End Property

Public Property Get Cnt() As Long
    Cnt = pCnt
End Property
Public Property Let Cnt(Value As Long)
    pCnt = Value
End Property

Reguläres Modul

Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub CheckForQuads()
    Dim cQ As cQuad, dQ As Dictionary
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long, J As Long
    Dim wsData As Worksheet, wsRes As Worksheet, rRes As Range
    Dim V, W
    Dim sKey As String

Set wsData = Worksheets("Data")
Set wsRes = Worksheets("Results")
    Set rRes = wsRes.Cells(1, 10)

With wsData
    I = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row
    J = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Last Column
    vSrc = .Range(.Cells(1, 1), .Cells(I, J))
End With

Set dQ = New Dictionary
For I = 1 To UBound(vSrc, 1)

    'Size array for number of combos in each row
    V = Combos(Application.WorksheetFunction.Index(vSrc, I, 0))

    'create an object for each Quad, including each member, and the count
    For J = 1 To UBound(V, 1)
    Set cQ = New cQuad
        With cQ
            .Q1 = V(J, 1)
            .Q2 = V(J, 2)
            .Q3 = V(J, 3)
            .Q4 = V(J, 4)
            .Cnt = 1
            sKey = Join(.Arr, Chr(1))

            'Add one to the count if Quad already exists
            If Not dQ.Exists(sKey) Then
                dQ.Add sKey, cQ
            Else
                dQ(sKey).Cnt = dQ(sKey).Cnt + 1
            End If

        End With
    Next J
Next I

'Output the results
'set a threshold
Const TH As Long = 1

'Size the output array
I = 0
For Each V In dQ.Keys
    If dQ(V).Cnt >= TH Then I = I + 1
Next V
ReDim vRes(0 To I, 1 To 5)

'Headers
vRes(0, 1) = "Value 1"
vRes(0, 2) = "Value 2"
vRes(0, 3) = "Value 3"
vRes(0, 4) = "Value 4"
vRes(0, 5) = "Count"

'Output the data
I = 0
For Each V In dQ.Keys
    Set cQ = dQ(V)
    With cQ
        If .Cnt >= TH Then
            I = I + 1
            vRes(I, 1) = .Q1
            vRes(I, 2) = .Q2
            vRes(I, 3) = .Q3
            vRes(I, 4) = .Q4
            vRes(I, 5) = .Cnt
        End If
    End With
Next V

'Output the data
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
    .Sort key1:=.Columns(.Columns.Count), _
        order1:=xlDescending, Header:=xlYes, MatchCase:=False
End With
End Sub

Function Combos(Vals)
    Dim I As Long, J As Long, K As Long, L As Long, M As Long
    Dim V

ReDim V(1 To WorksheetFunction.Combin(UBound(Vals), 4), 1 To 4)
M = 0
For I = 1 To UBound(Vals) - 3
    For J = I + 1 To UBound(Vals) - 2
        For K = J + 1 To UBound(Vals) - 1
            For L = K + 1 To UBound(Vals)
                M = M + 1
                V(M, 1) = Vals(I)
                V(M, 2) = Vals(J)
                V(M, 3) = Vals(K)
                V(M, 4) = Vals(L)
            Next L
        Next K
    Next J
Next I

Combos = V

End Function

verwandte Informationen