Excel VBAで複数の列に均等に要素を均等に分散する

Question

初回ポスター、長時間の読者。

これに従わないとお詫び申し上げます。

私には名字と姓のリストを持つスプレッドシートがあります。私がしたいのは、同じ姓を持ち、同じスプレッドシート内の3つの参照列に等間隔に置かれ、コンマで区切られた最初のすべての名前を取ることです。

Example of Completed Sheet

200+の名前と成長があるので、私はVBAでこれをやりたい、と後でコードは、より多くのワークブックを作成し、移入するために、この情報を使用します。

これまでのところ、3つ以下のファーストネーム（すなわち、1つのカラムあたり1つ）を持つすべての姓に対して機能していますが、3つ以上のファーストネームがある姓の場合は機能しません。

私は、すべての名前を配列に読み込み、3つ以上の名前を持つ要素を別の配列に分割し、これらを一緒に結合してコンマで区切って、シートの関連する列に転送することを考えました。

しかし何らかの理由で、複数の名前を列に出力することができません。

私はこれでいくつかの試みをしましたが、これは私の最近の試みです。

Private Sub cmdUpdate_Click() 
Dim i As Long 
Dim j As Long 
Dim k As Long 
Dim l As Long 
Dim m As Long 

Dim namesPerCol As Long 

Dim strLastNameMatches As String 
Dim arrNames() As String 
Dim arrMultiNames(3) As String 

Application.ScreenUpdating = False 

With ActiveSheet 
    'Finds the last row with data in it 
    lngLastRow = .Cells(.Rows.count, "A").End(xlUp).Row 
End With 

'Sort the Columns 
Columns("A:E").Sort key1:=Range("A1"), Header:=xlYes 

'Loop through the LastNames 
For i = 2 To lngLastRow 
    'Second loop through the LastNames 
    For j = 2 To lngLastRow 
     'If the last name matches 
     If Cells(i, 2).Value = Cells(j, 2).Value Then 
      'If the cell is empty then 
      If Range("C" & i).Value = "" Then 
       'Place the name in colA into colC 
       Range("C" & i).Value = Range("A" & j).Value 
      Else 
       'If the cell is not empty, then place a comma and space and then the value from colA 
       Range("C" & i).Value = Range("C" & i).Value & ", " & Range("A" & j).Value 
      End If 
     End If 
    Next j 
Next i 

For i = 2 To lngLastRow 
    strLastNameMatches = Range("C" & i).Value 
    arrNames = Split(strLastNameMatches, ", ") 
    If UBound(arrNames) > 2 Then 
     namesPerCol = UBound(arrNames)/3 
     For l = 0 To 1 
      For k = LBound(arrNames) To namesPerCol 
       arrMultiNames(l) = arrNames(k) & ", " 
      Next k 
     Next l 

     For m = LBound(arrMultiNames) To UBound(arrMultiNames) 
      Select Case m 
       Case 0 
        Range("C" & i).Value = arrMultiNames(m) 
       Case 1 
        Range("D" & i).Value = arrMultiNames(m) 
       Case 2 
        Range("E" & i).Value = arrMultiNames(m) 
      End Select 
     Next m 

    Else 
     For j = LBound(arrNames) To UBound(arrNames) 
      Select Case j 
       Case 0 
        Range("C" & i).Value = arrNames(j) 
       Case 1 
        Range("D" & i).Value = arrNames(j) 
       Case 2 
        Range("I" & i).Value = arrNames(j) 
      End Select 
     Next j 
    End If 
Next i 

Application.ScreenUpdating = True 
End Sub 

悪い品質のコーディングのお詫びは、私はそれがすべて動作したらそれをあきらめて作業します。

私は均等に3列にわたって名前をこのコード分割を出すために得ることができるすべてのヘルプは非常にあなたがより多くのツリー構造にデータを保存することができれば、この作業は単純かもしれません

Answer 1

を理解されるであろう。これを行うには多くの方法があります。私はCollectionオブジェクトを使用しました。これは、未知数のアイテムを扱いやすいためです。基本的には、コレクション内にコレクションがあります。つまり、各姓のファーストネームのコレクションです。

以下のサンプルは、（また、3のスプリットにハードコードされている）非常に初歩的なディストリビューションコードを使用しますが、ポイントは、ツリーを通って、下の反復がはるかに簡単であるということである。

Dim lastList As Collection, firstList As Collection 
Dim lastText As String, firstText As String 
Dim data As Variant, last As Variant, first As Variant 
Dim output() As Variant, dist(1 To 3) As Long 
Dim str As String 
Dim r As Long, c As Long, i As Long 

'Read data into an array 
With Sheet1 
    data = .Range(.Range("A1"), .Cells(.Rows.Count, "B").End(xlUp)).Value2 
End With 

'Create lists of unique lastnames containing the firstnames 
Set lastList = New Collection 
For r = 2 To UBound(data, 1) 

    firstText = CStr(data(r, 1)) 
    lastText = CStr(data(r, 2)) 

    Set firstList = Nothing 
    On Error Resume Next 
    Set firstList = lastList(lastText) 
    On Error GoTo 0 

    If firstList Is Nothing Then 
     Set firstList = New Collection 
     lastList.Add firstList, lastText 
    End If 

    firstList.Add firstText 

Next 

'Write results to sheet 
ReDim output(1 To UBound(data, 1) - 1, 1 To 3) 
For r = 2 To UBound(data, 1) 
    lastText = CStr(data(r, 2)) 
    Set firstList = lastList(lastText) 
    'Calculate the distribution 
    dist(3) = firstList.Count/3 'thanks @Comitern 
    dist(2) = dist(3) 
    dist(1) = firstList.Count - dist(2) - dist(3) 
    i = 1: c = 1: str = "" 
    For Each first In firstList 
     str = str & IIf(i > 1, ", ", "") & first 
     i = i + 1 
     If i > dist(c) Then 
      output(r - 1, c) = str 
      i = 1: c = c + 1: str = "" 
     End If 
    Next 
Next 
Sheet1.Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output