作者ktll (浪迹天涯的旅人)
看板Office
标题[算表] VBA筛选後另存新档
时间Mon Aug 24 22:16:28 2020
软体:EXCEL
版本:2016
目前的资料如下：
编号 总公司 分公司 部门组别 姓名 性别 报名
1 A B F 甲 男 Y
2 A B F 乙 男 N
3 A B G 丙 女 Y
4 A C H 丁 女 Y
5 A C I 戊 男 Y
6 A D J 己 女 Y
7 A D K 庚 男 N
8 A E L 辛 女 Y
9 A E M 壬 男 N
想依分公司进行筛选後另存新档 (即将所有分公司存在同一个档案)
内容为
编号 总公司 分公司 部门组别 姓名 性别 报名
1 A B F 甲 男 Y
2 A B F 乙 男 N
3 A B G 丙 女 Y
存档为B.xlsx
有参考中的资料
Sub Macro1()
Dim rLastCell As Range
Dim strName As String
Dim lLoop As Long
Dim wbNew As Workbook
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], _
SearchDirection:=xlPrevious)
For lLoop = 2 To rLastCell.Row
Set wbNew = Workbooks.Add
.Range("1:1," & lLoop & ":" & lLoop).EntireRow.Copy _
Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:=ThisWorkbook.Path _
& Application.PathSeparator & .Cells(lLoop, 1) & ".xls"
Next lLoop
End With
End Sub
但筛选出来的都只有第一列，以及存成的档案都是.xls
所以想请问各位大大该怎麽修改程式,让档案可以顺利筛选与存成.xlsx
谢谢
--
※ 发信站: 批踢踢实业坊(ptt.cc), 来自: 42.76.199.137 (台湾)
※ 文章网址: https://webptt.com/cn.aspx?n=bbs/Office/M.1598278592.A.810.html
※ 编辑: ktll (42.76.199.137 台湾), 08/24/2020 22:22:55
※ 编辑: ktll (42.76.199.137 台湾), 08/24/2020 22:24:22
1F：→ soyoso: 副档名要存为.xlsx，".xls"改为".xlsx" 08/24 22:27
2F：→ soyoso: 内文举例来看分公司有排序的话 08/24 22:38
※ 编辑: ktll (42.76.199.137 台湾), 08/24/2020 22:53:38
6F：→ ktll: 另外想请问 08/24 23:48
7F：→ ktll: 在复制贴上後 再加上自动调整栏宽与列高 要怎麽设定 谢谢 08/24 23:48
9F：→ soyoso: 是什麽错误讯息提供一下。另外并没有按照我提供的第二方法 08/25 00:05
10F：→ soyoso: ，cnt = lLoop + cnt-1，我不是这麽写的 08/25 00:05
11F：→ soyoso: 自动调整栏宽与列高，range.autofit 08/25 00:05
13F：→ ktll: 已改成 lLoop = lLoop + cnt - 1 谢谢 08/25 00:14
14F：→ soyoso: cells(...,1)这里数字的1打成英文小写的L(l)吗？ 08/25 00:18
16F：→ soyoso: 该错误讯息 08/25 00:19
17F：→ ktll: 原来是打错 谢谢你！ 另外刚刚持续执行後 存档的档 08/25 00:26
18F：→ ktll: 未照分公司命名 反而照编号命名 这部分的话 需要怎麽修改呢? 08/25 00:27
19F：→ soyoso: 巨集所写cells(...,1)的1就是以a栏编号做为档名，分公司的 08/25 00:33
20F：→ soyoso: 话为3 08/25 00:33
21F：→ ktll: 好的！ 真的太感谢你了！ 08/25 00:34