求大神帮忙拆分总表

Noyan · 发表于 2019-1-19 13:41

求大神帮忙拆分总表将总表按周期拆分，具体见图和附件。10086个感谢！！！

朱荣兴 · 发表于 2019-1-19 14:08

提示: 作者被禁止或删除内容自动屏蔽

ykqrs · 发表于 2019-1-19 15:37

Sub qq()
Dim rng, d, r%, i%, sht As Worksheet, s As Date
Dim x%, n%, aa, ws As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
With ActiveSheet
For Each sht In Sheets
If sht.Name <> .Name Then sht.Delete
Next
Set rng = .[a1].Resize(4, 10)
r = .Cells(Rows.Count, 1).End(xlUp).Row
n = 1
For i = 5 To r
If .Cells(i, 8).Value >= 600 Then
x = x + 1
Set d("合格" & x) = Union(rng, .Cells(i - n + 1, 1).Resize(n, 10))
n = 1
Else
n = n + 1
End If
Next
End With
For Each aa In d.keys
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = aa
d(aa).Copy .Range("a1")
.[a3] = Left(.[a3].Value, Application.Find("考核日期：", .[a3].Value) + 4) & Format(.[a5].Value, "yyyy年m月d日")
Set rng = .Cells(Rows.Count, 1).End(xlUp)
.Columns("a").AutoFit
s = Format(DateSerial(Year(rng), Month(rng) + 1, 20), "yyyy年m月d日")
.[a2] = Left(.[a2].Value, Application.Find("制表时间：", .[a2].Value) + 4) & s
End With
Next
Application.DisplayAlerts = True
End Sub

复制代码

ykqrs · 发表于 2019-1-19 15:40

点击按钮

abc.rar (23.41 KB, 下载次数: 3)

Noyan · 发表于 2019-1-19 19:43

朱荣兴发表于 2019-1-19 14:08
只是完成了拆分，其他的没弄，关键是没法弄，因为你的表头的第二行的结构问题，
Sub 按周期拆分()
Applic ...

虽然没达到最终的效果，还是谢谢版主

Noyan · 发表于 2019-1-19 19:48

ykqrs 发表于 2019-1-19 15:40
点击按钮

大神辛苦了，100862个赞，完全符合要求。大神能否注释一下，方便学习。还有个小问题，就是制表日期显示出来是2018-5-20，而不是2018年5月20日，看了代码，已经设置过了，不懂问题在哪，还请大神看看。

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

[求助] 求大神帮忙拆分总表

朱荣兴朱荣兴当前离线性别保密 UID 1318548 阅读权限 0 注册时间 2011-2-2 在线时间小时最后登录 1970-1-1 积分 19282 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2019-1-19 14:08 \| 显示全部楼层 [广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报