有段EXCEL VBA代码处理不来，有高手的出来帮忙解决下

应该是Tranpose的问题：
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long, j As Long
Dim dic As Object
Dim arr, brr, a, b
Sheet2.Range("A1").CurrentRegion.Offset(1, 0).Clear
lastrow = Range("C" & Rows.Count).End(xlUp).Row
If lastrow <= 1 Then Exit Sub
Set dic = CreateObject("Scripting.dictionary")
arr = Sheet1.Range("A1:I" & lastrow)
For i = 2 To UBound(arr)
dic(arr(i, 4)) = dic(arr(i, 4)) & Format(arr(i, 5), "yy-mm-dd，hh:mm") & vbCrLf
Next
ReDim brr(1 To dic.Count, 1 To 2)
a = dic.Keys
b = dic.Items
For i = 1 To dic.Count
brr(i, 1) = a(i - 1)
brr(i, 2) = Left(b(i - 1), Len(b(i - 1)) - 1)
Next
Sheet2.Range("b2").Resize(dic.Count, 2) = brr
Range("A:E").Columns.AutoFit
Set dic = Nothing
MsgBox "数据处理完毕", vbInformation, "消息提示"
Application.ScreenUpdating = True
End Sub追问

你的代码不错，可是最多只能处理到57行，处理第58行相同人名的时候就会出现调试错误，请问有没有办法弄到57行以上，我们表相同人名至少都有200行，麻烦再帮我处理下代码，谢谢了。

追答

我用3人1500行数据测试通过，没有发现你说的问题。
只是excel最大行高不能超过409.5磅，根据字体的大小显示会在30~40行之间，若相同人名至少都有200行，那你还要想其他办法。

追问

刚把你的代码重新复制进去又测试了下，同一人名58行，点击合并显示：运行时错误‘1004’，再点击调试按钮自动跳转到这行代码：Sheet2.Range("b2").Resize(dic.Count, 2) = brr，这行代码黄色显示。

删除一行变57行再点击合并这种情况又没有了。

追答

我又试了一下内有发现问题，怀疑是不是版本的问题，我的是2010版。

如方便请把出问题的文件上传再看一下。

追问

我刚下了个2010版的试了下没问题，

之前用在2003版上就有这个问题。现在单个单元格只支持409.5磅，那可不可以麻烦你再帮我弄下，帮我把输出自动拆行的功能去掉，这样单个单元格就可以显示处理过的所有数据了。

另外输出非得要工作表1员工工号一列有数据才行，没有数据的话点合并无效，弄的每次都要弄些数字来填充这一列，这个问题能否也帮我修正下，在这列无数据的情况下，让表也能正常处理姓名一列。

追答

修改后的代码，注释掉的那一行是每行按10个日期排列：

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long, j As Long
Dim dic As Object
Dim arr, brr, a, b
Sheet2.Range("A1").CurrentRegion.Offset(1, 0).Clear
lastrow = Range("D" & Rows.Count).End(xlUp).Row
If lastrow <= 1 Then Exit Sub
Set dic = CreateObject("Scripting.dictionary")
arr = Sheet1.Range("A1:I" & lastrow)
For i = 2 To UBound(arr)
    dic(arr(i, 4)) = dic(arr(i, 4)) & Format(arr(i, 5), "yy-mm-dd hh:mm") & "；"
    'dic(arr(i, 4)) = IIf(Len(dic(arr(i, 4))) Mod 150 = 0, Left(dic(arr(i, 4)), _
    Len(dic(arr(i, 4))) - 1) & vbLf, dic(arr(i, 4)))
Next
ReDim brr(1 To dic.Count, 1 To 2)
a = dic.Keys
b = dic.Items
For i = 1 To dic.Count
    brr(i, 1) = a(i - 1)
    brr(i, 2) = Left(b(i - 1), Len(b(i - 1)) - 1)
Next
Sheet2.Range("b2").Resize(dic.Count, 2) = brr
Sheet2.Range("A:E").Columns.AutoFit
Sheet2.Columns("C:C").WrapText = True
Set dic = Nothing
MsgBox "数据处理完毕", vbInformation, "消息提示"
Application.ScreenUpdating = True
End Sub

追问

sheet2 A，D，E，F这 四个列从第2行开始自行填写的数据在合并输出后会被自动清空，有没有办法让他们不被清空，麻烦了，再帮我修下，真的需要，谢谢

追答

修改第7行：
Sheet2.Range("b2:c" & Sheet2.Cells(Rows.Count, 3).End(3).Row).ClearContents
另外你已经采纳的代码能达到要求吗？使用Preserve的动态数组在执行中只能重定义数组最末维的大小，改动除末维之外的任一维都会出错的？！

本回答被提问者采纳

我给你私信了，看私信吧