[已解决]用VBA特殊的多行换一行

guogongyi · 发表于 2014-10-16 19:43

本帖最后由 guogongyi 于 2014-10-21 18:20 编辑

      说明
1.“姓名”栏有重复的，想把“现文化程度”栏至“所学专业”栏共5个栏内容向右复制，复制的顺序要求是原来的位置留“毕(肄)业时间”栏时间由最早的，把其他行按“毕(肄)业时间”栏时间从早到晚的顺序，粘贴到右边，并把除最早的这行留下，其他“姓名”重复项删除掉。就像“结果”标签的一样。谢谢！

2.行数很多，请用VBA完成。谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2014-10-17 15:31

也不是很烦，就是两两比较的排序办法有点笨而已。

跳转到最佳答案楼层

su45 · 发表于 2014-10-16 19:56

好像有点繁

guogongyi · 发表于 2014-10-16 20:06

su45 发表于 2014-10-16 19:56
好像有点繁

能不能给做一下，或先排序后复制也行，不删除已经复制的删除也行，关键是把后五个向右排列。

guogongyi · 发表于 2014-10-16 20:13

guogongyi 发表于 2014-10-16 20:06
能不能给做一下，或先排序后复制也行，不删除已经复制的删除也行，关键是把后五个向右排列。

我先排序了，这样能好做一些吗？

guogongyi · 发表于 2014-10-17 14:30

哪位大侠帮帮我，我谢谢你了

grf1973 · 发表于 2014-10-17 15:30

Sub tt()
Dim sh As Worksheet
Set d = CreateObject("scripting.dictionary") '记录重名
Set d1 = CreateObject("scripting.dictionary") '记录姓名出现的次数
r = Sheet1.[a65536].End(3).Row
arr = Sheet1.Range("a1:o" & r)
Set sh = Sheets("结果")
For i = 1 To UBound(arr)
x = arr(i, 10) '姓名
d1(x) = d1(x) + 1 '姓名出现的次数
If Not d.exists(x) Then
n = n + 1 '姓名在新表中的行位置
d(x) = n
sh.Cells(n, 1).Resize(1, 15) = Sheet1.Cells(i, 1).Resize(1, 15).Value '第一次出现，复制1--15列
Else '第二次以上出现
p = d(x)
c = 6 + 5 * d1(x)
sh.Cells(p, c).Resize(1, 5) = Sheet1.Cells(i, 11).Resize(1, 5).Value '复制11-16列，到新表指定列
sh.Cells(1, c).Resize(1, 5) = Sheet1.Cells(1, 11).Resize(1, 5).Value '新表头
For j1 = 11 To c - 5 Step 5 '判断毕业日期并排序
arr1 = sh.Cells(p, j1).Resize(1, 5)
For j2 = 16 To c Step 5
arr2 = sh.Cells(p, j2).Resize(1, 5)
If CDate(arr1(1, 3)) > CDate(arr2(1, 3)) Then '前一日期大于后一日期，交换
sh.Cells(p, j1).Resize(1, 5) = arr2
sh.Cells(p, j2).Resize(1, 5) = arr1
End If
Next
Next
End If
Next
sh.Activate
End Sub

复制代码

grf1973 · 发表于 2014-10-17 15:31

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

也不是很烦，就是两两比较的排序办法有点笨而已。

guogongyi · 发表于 2014-10-17 18:39

大侠帮帮忙

guogongyi · 发表于 2014-10-17 20:06

grf1973 发表于 2014-10-17 15:31
也不是很烦，就是两两比较的排序办法有点笨而已。

谢谢，转换的很好，但有的日期变成了数字，再请您看一下。

		自动登录	找回密码
密码			注册