5 열로 Excel에서 여러 행을 동일하게 클러스터하는 방법

Question

저는 Excel VBA의 초보자이며 각 구성원이 해당 Crift 데이터에 따라 분류 된 그룹으로 에이전트 이름/ID를 균등하게 나눠 씁니다. 프로모터, 중성 또는 비평 자. 이와는 별도로 Crift 분류가있는 상담원은 매출액 또는 판매액이 없는지 여부를 확인할 수 있습니다. 마지막으로 통화 시간 (짧음 (10 분 미만), 중간 (10-20 분) 및 긴 (위 20 분))은 각 그룹으로 동등하게 나뉘어 하나의 그룹에서 평가 될 짧은, 중간 및 긴 호출이 있도록합니다.

Agent Name/ID Sales/NonSales Crift (P-N-D) Call Duration (in min) Repeats 
152325   N     N   8.00      Y 
152336   Y     N   12.00     Y 
152040   Y     P   10.00     Y 
152041   Y     P   13.00     Y 
152046   N     D   10.00     N 
152189   N     N   15.00     Y 
151794   Y     P   24.00     N 
152052   Y     P   20.00     Y 
151906   Y     P   23.50     N 
151909   N     D   15.67     Y 
151893   N     N   20.36     N 
152048   Y     D   21.00     N 
151903   Y     N   19.00     N 
152044   Y     P   18.25     N 
152032   N     P   29.15     Y 
152290   Y     N   26.00     N 
151740   N     D   10.00     Y 
168334   N     D   6.00      N 
200679   Y     N   8.00      Y 
152037   N     D   7.56      Y 
152026   Y     D   8.16      Y 
152055   Y     P   9.28      Y 
152307   N     P   4.26      N 
152132   Y     P   16.64     N 
152004   N     D   16.16     Y 
152017   Y     P   25.00     Y 
152021   N     D   26.00     Y 
151914   N     P   29.16     Y 
151922   N     N   24.98     Y 

정말 고맙습니다.

Answer 1

Private Type Records 
Dimension() As Double 
Distance() As Double 
Cluster As Integer 

End Type 

Dim Table As Range 
Dim Record() As Records 
Dim Centroid() As Records 

Sub Run() 

If Not Grouping Then 
    Call MsgBox("Error: " & Err.Description, vbExclamation, "Clustering Error") 
End If 

End Sub 

Function Grouping() As Boolean 
Dim Site As String 

Site = Application.InputBox("VXI Site") 
Worksheets("Data Base").Activate 
Range("B1").Select 
ActiveCell.Offset(2, 0).Value = Site 
Cells(2, 1).Font.Bold = True 
Cells(2, 2).HorizontalAlignment = xlCenter 

Dim numClusters As Integer 
numClusters = Application.InputBox("Specify Number of QA Evaluator", "Grouping", Type:=1) 
ActiveCell.Offset(3, 0).Value = numClusters 
Cells(4, 2).Font.Bold = True 
Cells(4, 2).HorizontalAlignment = xlCenter 

If Not numClusters > 0 Or numClusters = False Then 
    Exit Function  'Cancelled 
End If 

MsgBox Site & " was an identified site" & " with " & numClusters & " QA Evaluators." 

Dim dataSheet, groupSheet As Worksheet 
Set groupSheet = Worksheets("Grouping") 
Set dataSheet = Worksheets("Data Base") 


'dataSheet.Range("A7:A100000").Copy Destination:=dataSheet.Range("g:g") 

Dim numAgent As Integer 
numAgent = dataSheet.Range("A7:A100000").End(xlDown).Row 

Dim startRow As Integer 
startRow = 2 
Dim startCol As Integer 
startCol = 1 
Dim agentNumber As Integer 


For i = 1 To numClusters 
For j = 1 To Round(numAgent/numClusters, 0) 
    agentNumber = Int((numAgent - 1 + 1) * Rnd() + 1) 
    groupSheet.Cells(startRow, startCol).Value = dataSheet.Cells(agentNumber, 7).Value 
    dataSheet.Cells(agentNumber, 7).Delete Shift:=xlUp 
    numAgent = numAgent - 1 
    startRow = startRow + 1 
Next j 

If i < 7 Then 
    startRow = 2 
    startCol = startCol + 1 
ElseIf i = 7 Then 
    startRow = 14 
    startCol = 1 
Else 
    startRow = 14 
    startCol = startCol + 1 
End If 
Next i 


Grouping_Error: 
Grouping = (Err.Number = 0) 

End Function 

Sub SearchForString() 

Dim LSearchRow As Integer 
Dim LCopyToRow As Integer 

On Error GoTo Err_Execute 

'Start search in row 7 
LSearchRow = 7 

'Start copying data to row 4 in Grouping (row counter variable) 
LCopyToRow = 4 

While Len(Range("A" & CStr(LSearchRow)).Value) < 10 

    'If value in column E = "Mail Box", copy entire row to Sheet2 
    If Range("E" & CStr(LSearchRow)).Value = "Y" And "N" Then 

    'Select row in Sheet1 to copy 
    Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
    Selection.Copy 

    'Paste row into Sheet2 in next row 
    Sheets("Grouping").Select 
    Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select 
    ActiveSheet.Paste 

    'Move counter to next row 
    LCopyToRow = LCopyToRow + 1 

    'Go back to Sheet1 to continue searching 
    Sheets("Data Base").Select 

    End If 

    LSearchRow = LSearchRow + 1 

Wend 

'Position on cell A3 
Application.CutCopyMode = False 
Range("A").Select 

MsgBox "All matching data has been copied." 

Exit Sub 

Err_Execute: 
MsgBox "An error occurred." 

End Sub