☰

일반 모듈

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 --> References이것이 Microsoft Scripting Runtime배포될 예정이라면 지연 바인딩으로 변경해야 할 것입니다).

첫 번째 줄 이후 쿼드를 수집할 때 사전을 사용하여 쿼드가 이미 존재하는지 테스트할 수 있습니다. 그렇다면 개수에 1을 추가합니다. 그렇지 않은 경우 새 쿼드로 저장합니다.

범위는 A열의 마지막 행을 찾아서 크기가 지정됩니다. 행 1의 마지막 열입니다. 워크시트에 표시된 대로 데이터가 A1에서 시작하고 머리글 행이 없다고 가정합니다. 그렇지 않은 경우 일부 조정이 필요할 수 있습니다.

또한 각 행의 항목이 정렬되어 있다고 가정합니다. 그렇지 않은 경우 쿼드를 생성하기 전에 정렬 루틴을 추가해야 합니다.

편집하다: 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

관련 정보