[已解决]工作表拆成工作薄

rainbowsjh · 发表于 2013-5-22 21:49

本帖最后由 rainbowsjh 于 2013-5-22 21:55 编辑

见附件。想按A列Region内容拆成四个工作薄，注意不是工作表，是独立的工作薄。每个工作薄中一个工作表，表名称为Region里的BJ HZ CQ SH; 表内容即为按A列四项筛选出来的内容。请教高手解决！

工作表拆分成工作薄.rar (29.27 KB, 下载次数: 8)

ligh1298 · 发表于 2013-5-23 06:42

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

单击隐藏图章

本帖最后由 ligh1298 于 2013-5-23 06:56 编辑

试着做了一个，不知是否符合要求？

无聊的疯子 · 发表于 2013-5-23 08:52

使用 range.find 的方法来做的查找

使用时,运行 CC 就行了

Sub cc()
Dim Arr(), Brr(), Nm As String, Wb As Workbook, Rng As Range
Dim Sa As Long, Ea As Long, X As Long, Hx As Long
With Sheets("Sheet1") '指定操作的表
Set Rng = .Range("A1:G1") '提取标题行
X = .Range("A65536").End(xlUp).Row '提A列取最后一个非空行位置
With .Range("A2:G" & X) '指定操作数据源
Arr = .Value '将值放到数组,后面会重新写回到单元格
.Sort .Cells(1, 1), 1 '排序
For Hx = 1 To UBound(Arr) '在数组中循环
Nm = ThisWorkbook.Path & "" & Arr(Hx, 1) & ".xls" '设置文件保存路径及文件名称 .xls 是后面另存时设置的格式
If Len(Dir(Nm)) > 0 Then Kill Nm '如果文件已经存在,则删除已存在的文件
Sa = Ro(Arr(Hx, 1), 1) '提取第一个数据位置
Ea = Ro(Arr(Hx, 1), 2) '提取最后一个数据位置
Brr = Range(Cells(Sa, "A"), Cells(Ea, "G")).Value '将数据区域放到数组
Set Wb = Workbooks.Add(xlWBATWorksheet) '新建一个工作薄
Wb.SaveAs Nm, 56 '工作薄另存为 xls 格式
With Wb.Sheets(1) '指定操作该工作薄的第一个工作表
.Range("A1:G1").Value = Rng.Value '写入表头
.Range("A2").Resize(UBound(Brr), UBound(Brr, 2)).Value = Brr '写入数据
.Range("B2").Resize(UBound(Brr), UBound(Brr, 2) - 2).Style = "Percent" '设置单元格格式 %
End With
Wb.Close True '关闭文件并保存
Hx = Ea '重置 hx 的值
Next Hx
.Value = Arr '将数据写回单元格,对于用作排序后数据还原
End With
End With
MsgBox "数据拆分完毕!!"
End Sub
Private Function Ro(ByVal Zhi As String, Fx As Byte) '根据参数查找数据位置
Ro = Sheet1.Range("A:A").Find(Zhi, , , 1, , Fx).Row
End Function

复制代码

无聊的疯子 · 发表于 2013-5-23 08:55

在 .Range("B2").Resize(UBound(Brr), UBound(Brr, 2) - 2).Style = "Percent" '设置单元格格式 %
下面添加一句代码,用于修改工作表名称
.Name = Arr(Hx, 1) '|修改工作表的名称

rainbowsjh · 发表于 2013-5-23 09:14

ligh1298 发表于 2013-5-23 06:42
试着做了一个，不知是否符合要求？

老师你真强大啊！！！！！！！！！！

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

[已解决]工作表拆成工作薄

相关帖子