☰

常規模組

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba microsoft-excel-2007 macros
常規模組

下面的 VBA 程式碼從需要 6 列資料（A1、B1、C1、D1、E1、F1）的給定資料中提取最常見的重複對和三元組，並顯示它們出現的次數。我想讓這段程式碼從包含 22 列資料 (A1,B1,C1,....U1,V1) 的資料集中僅提取四聯體，並以類似的方式顯示它們出現的次數。我不確定這是否是 Excel 無法處理的資料太多。

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

結束子

答案1

由於在處理每行 22 個單元格時可能存在大量四邊形，因此我建議採用與處理雙倍和三倍數不同的方法。

我將創建一個用戶定義的物件（類別）來包含有關四邊形內容和計數的資訊。 （我還引入了一種創建四邊形項目數組的方法）。然後我將在字典物件中收集四邊形 - 在下面的程式碼中我使用了早期綁定（在Tools --> Referencesto下方設定一個引用Microsoft Scripting Runtime，但如果要分發它，您可能應該更改為後期綁定。

當收集第一行之後的四邊形時，我們可以使用字典來測試四邊形是否已經存在；如果是，我們將計數加一；如果沒有，我們將其儲存為新的四邊形。

透過尋找 A 列中的最後一行來確定範圍的大小；以及第 1 行的最後一列。如果情況並非如此，您可能需要進行一些調整。

它還假設每行中的條目都已排序。如果不是這種情況，您將需要在產生四邊形之前新增排序例程。

編輯: 請注意，由於 Excel 的行限制，如果您所需的輸出包含超過 2^20 個四邊形，則例程將崩潰（並出現 1004 錯誤）。至少有兩種方法可以處理這個問題：

  • 增加閾值，以便僅輸出計數為 2、3 或適合單組列所需的任何值的四邊形（可能是最簡單的方法）

  • 更改輸出例程以便將輸出分佈到多組列上。

班級模組

請務必將其重新命名為 cQuad

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

常規模組

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

相關內容