如何修改现有VBA代码实现一行最多显示4条数据，超出自动换行？

完全可以实现需求，以下提供两种常用实现方案：

方案1：单元格内换行展示 #

效果说明 #

每个唯一主键仅占用1行，对应值列单元格内每4条数据自动换行，开启单元格自动换行后即可直观看到每行4条的效果。

完整代码 #

Option Explicit

Sub InvoiceDataGrouping()
    Dim DataSet As Variant, Counter As Long, Dict As Object, CountDict As Object
  
    Set Dict = CreateObject("Scripting.Dictionary") '存拼接后的内容
    Set CountDict = CreateObject("Scripting.Dictionary") '存每个主键对应的值数量
    
    '读取A、B列所有数据
    DataSet = Sheets("DO").Range("A1", Range("B" & Rows.Count).End(3)).Value2
  
    For Counter = 1 To UBound(DataSet)
        If Not Dict.Exists(DataSet(Counter, 1)) Then
            '首次出现的主键直接赋值
            Dict(DataSet(Counter, 1)) = DataSet(Counter, 2)
            CountDict(DataSet(Counter, 1)) = 1
        Else
            CountDict(DataSet(Counter, 1)) = CountDict(DataSet(Counter, 1)) + 1
            '每满4条就加换行符，否则加空格分隔
            If CountDict(DataSet(Counter, 1)) Mod 4 = 1 Then
                Dict(DataSet(Counter, 1)) = Dict(DataSet(Counter, 1)) & vbCrLf & DataSet(Counter, 2)
            Else
                Dict(DataSet(Counter, 1)) = Dict(DataSet(Counter, 1)) & " " & DataSet(Counter, 2)
            End If
        End If
    Next
  
    '输出结果
    Sheets("DO").Range("E1").Resize(Dict.Count, 2).Value = Application.Transpose(Array(Dict.keys, Dict.items))
    '开启F列自动换行
    Sheets("DO").Range("F:F").WrapText = True
    
    '释放对象
    Set Dict = Nothing
    Set CountDict = Nothing
End Sub

方案2：跨行多列展示 #

效果说明 #

主键对应的值超过4条时自动新增行，每行最多放4条值，分别放在F~I列，主键列E可按需选择是否重复填充。

完整代码 #

Option Explicit

Sub InvoiceDataGrouping()
    Dim DataSet As Variant, Counter As Long, Dict As Object
    Dim OutputArr As Variant, Key As Variant, ValArr As Variant
    Dim RowIdx As Long, i As Long, j As Long
  
    Set Dict = CreateObject("Scripting.Dictionary")
    
    DataSet = Sheets("DO").Range("A1", Range("B" & Rows.Count).End(3)).Value2
  
    For Counter = 1 To UBound(DataSet)
        '用|分隔不同值方便后续拆分
        Dict(DataSet(Counter, 1)) = Dict(DataSet(Counter, 1)) & "|" & DataSet(Counter, 2)
    Next
  
    '预定义输出数组，预留足够行数
    ReDim OutputArr(1 To 10000, 1 To 5)
    RowIdx = 1
    
    For Each Key In Dict.Keys
        '去掉开头的|，拆分数组
        ValArr = Split(Mid(Dict(Key), 2), "|")
        '按每4个一组写入输出数组
        For i = 0 To UBound(ValArr) Step 4
            OutputArr(RowIdx, 1) = Key 'E列填主键，不需要重复可注释这行
            For j = 0 To 3
                If i + j > UBound(ValArr) Then Exit For
                OutputArr(RowIdx, j + 2) = ValArr(i + j)
            Next
            RowIdx = RowIdx + 1
        Next
    Next
    
    '清空原有输出区域并写入新结果
    Sheets("DO").Range("E:I").ClearContents
    Sheets("DO").Range("E1").Resize(RowIdx - 1, 5).Value = OutputArr
    
    Set Dict = Nothing
End Sub

内容的提问来源于stack exchange，提问作者tia