[已解决]在sheet1表中提取每批160人的信息到sheet2表

qinhuan66

爱疯 发表于 2013-4-11 20:58

谢谢老师！做得非常好。谢谢！
老师帮我看一下我做的一个附件可以吗？也是安排体检时间及人数的，不过有个表提取时出错如下图：
体检时间安排表.rar (18.71 KB, 下载次数: 4)

2013-4-11 21:51 上传

点击文件名下载附件


代码如下：
Sub 生成体检单位及人数明细()
    Dim d As Object, arr, brr(), i&, j&, m&, s&
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Cells(3, 3).Resize(Sheet1.Cells(Rows.Count, 3).End(3).Row - 2, 2).Value
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 1 To UBound(arr)
        s = d(arr(i, 1) & arr(i, 2))
        If s = Empty Then
            m = m + 1
            d(arr(i, 1) & arr(i, 2)) = m
            s = m
            brr(s, 1) = arr(i, 2)
            brr(s, 2) = arr(i, 1)
        End If
        brr(s, 3) = brr(s, 3) + 1
    Next
    d.RemoveAll
    For i = 1 To m
        If Not d.Exists(brr(i, 1)) Then
            d(brr(i, 1)) = "安排" & brr(i, 2) & brr(i, 3) & "人"
          Else
            d(brr(i, 1)) = d(brr(i, 1)) & "、" & brr(i, 2) & brr(i, 3) & "人"
        End If
    Next
    With Sheet3
        .[a1].CurrentRegion.Offset(1).ClearContents
        .[a2].Resize(d.Count).Value = Application.Transpose(d.Keys)
        .[b2].Resize(d.Count).Value = Application.Transpose(d.Items)
    End With
    Set d = Nothing
End Sub

qinhuan66

爱疯 发表于 2013-4-11 20:58

老师能否按单位代码的顺序提取，如果能按单位代码的顺序提取就很圆满了。谢谢。因为像一般单位，先行政单位后事业单位再到企业单位，谢谢

爱疯

体检时间安排表5.rar (21.1 KB, 下载次数: 8)

2013-4-11 22:18 上传

点击文件名下载附件
刚才在修改4。


体检时间安排表6.rar (26.29 KB, 下载次数: 3)

2013-4-12 11:38 上传

点击文件名下载附件
还是必须要先排降序，才行。


体检时间安排表7.rar (90.17 KB, 下载次数: 1)

2013-4-12 20:39 上传

点击文件名下载附件


小结：http://www.excelpx.com/thread-298786-1-1.html

qinhuan66

爱疯 发表于 2013-4-11 22:19
刚才在修改4。

老师可以帮我看一下我刚才20楼那个附件吗？好像是这个Application.Transpose(d.Items)不支持太长的字符。怎么改呢谢谢

爱疯

我不知道20#附件，3个表分别是做什么的？
除了本帖的问题，20#附件是不是还有其它的问题？

你把22#的代码，放到20#附件里，可能要修改对应的数据源工作表名，和输出区工作表名。
等你改完了，我好理解是不是解决了什么问题。
然后，再看其它的问题。

qinhuan66

爱疯 发表于 2013-4-11 22:32
我不知道20#附件，3个表分别是做什么的？
除了本帖的问题，20#附件是不是还有其它的问题？

好的我测试一下谢谢

爱疯

体检时间安排表b.rar (21.25 KB, 下载次数: 2)

2013-4-11 22:53 上传

点击文件名下载附件

不知是不是要这样