程序通不过,请高手们帮忙

yuan710825

请看附件,程序不能通过,如果加上on error resume next  完成不完全,如204有四人,但只填写三人,请高手帮完善一下.
Sub aa()

Dim arr, arr2, brr
Dim mycell As Range
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")

arr = Sheets("名单").Range("a1:b" & Sheets("名单").[a65536].End(xlUp).Row)
For i = 1 To UBound(arr)
  If Not dic.exists(Trim(arr(i, 2))) Then
     dic.Add Trim(arr(i, 2)), arr(i, 1)
  Else
     dic(Trim(arr(i, 2))) = dic(Trim(arr(i, 2))) & "," & arr(i, 1)
  End If
Next i
arr2 = dic.keys
For i = 0 To UBound(arr2)-1
  brr = Split(dic(arr2(i)), ",")
  Set mycell = Sheets("宿舍安排").Cells.Find(what:=Trim(arr2(i)), lookat:=xlWhole)
  mycell.Offset(1, 0).Resize(UBound(brr), 1) = Application.WorksheetFunction.Transpose(brr)
  Set mycell = Nothing
Next i
End Sub

[ 本帖最后由 yuan710825 于 2009-8-5 10:54 编辑 ]

zhaogang1960

试试看：
Sub aa()

Dim arr, arr2, brr
Dim mycell As Range
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")

arr = Sheets("名单").Range("a1:b" & Sheets("名单").[a65536].End(xlUp).Row)
For i = 1 To UBound(arr)
  If Not dic.exists(Trim(arr(i, 2))) Then
     dic.Add Trim(arr(i, 2)), arr(i, 1)
  Else
     dic(Trim(arr(i, 2))) = dic(Trim(arr(i, 2))) & "," & arr(i, 1)
  End If
Next i
arr2 = dic.keys
For i = 0 To UBound(arr2)
  brr = Split(dic(arr2(i)), ",")
  Set mycell = Sheets("宿舍安排").Cells.Find(what:=Trim(arr2(i)), lookat:=xlWhole)
  '下一句中UBound(brr) + 1
  If Not mycell Is Nothing Then mycell.Offset(1, 0).Resize(UBound(brr) + 1, 1) = Application.WorksheetFunction.Transpose(brr)
  Set mycell = Nothing
Next i
End Sub

yuan710825

zhaogang 1960 真的很强大,谢谢