Question

第一次发布海报，长时间阅读。

如果难以理解，请道歉。

我有一个电子表格，其中包含名字和姓氏的列表。我想要做的是取所有具有相同姓氏的名字，并将它们均匀地（ish）并用逗号分隔，放入同一电子表格中的3个参考列中;例如;

Example of Completed Sheet

我想在VBA中执行此操作，因为有200多个名称并且正在增长，稍后代码将使用此信息来创建和填充更多工作簿。

到目前为止，我的所有名字都有3个或更少的名字（即每列一个），但我不能让它适用于名字超过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

对于质量差的编码道歉，一旦工作完毕，我将努力将其整理好。

我可以获得任何帮助以获得此代码在三列中均匀分割名称将非常感激

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

在Excel VBA中均匀分布多列中的Arrary元素

1 个答案: