[已解决]求一VBA代码

apple_wong · 发表于 2012-1-13 08:46

每个月做完工资表，都要按工资表的部门剪切出来单独发给各个部门，工作量挺大的。
请问有没有老师能帮忙写段代码，如附件格式，运行后可以根据A列的“部门名称1”自动生成独立的工作簿！

最佳答案

sunjing-zxl

2012-1-15 15:50

本帖最后由 sunjing-zxl 于 2012-1-15 15:55 编辑

前面代码在03运行有错，下面改动了一下

Sub 拆分()
Dim Sht As Workbook, Bm As String
Dim Hx, Lx, Hx1, X, X2, arr
Dim Fd As FileDialog, Path As String
Application.ScreenUpdating = False
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
If Fd.Show = -1 Then Path = Fd.SelectedItems(1) & IIf(Right(Fd.SelectedItems(1), 1) = "", "", "") Else: Exit Sub
With Sheet1
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("A1").End(xlToRight).Column
arr = .Range(.Cells(1, 1), Cells(Hx, Lx))
For X = 2 To Hx
Bm = arr(X, 1)
For X2 = X + 1 To Hx
If arr(X2, 1) <> Bm Or X2 = Hx Then
If X2 = Hx Then
Hx1 = Hx
Else
Hx1 = X2 - 1
End If
GoTo Y
End If
Next
Y:
Set Sht = Workbooks.Add
Worksheets(1).Name = Bm
.Range(.Cells(1, 1), .Cells(1, Lx)).Copy Range("A1")
.Range(.Cells(X, 1), .Cells(Hx1, Lx)).Copy Range("A2")
ActiveWorkbook.SaveAs Path & Bm & ".xls" ’去点了 xlWorkbookDefault就适合03了
ActiveWorkbook.Close
X = Hx1
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

菜鸟锐 · 发表于 2012-1-13 09:13

帮您i顶一下，看一下有人会不~~

sunjing-zxl · 发表于 2012-1-13 09:32

Sub 拆分()
Dim Sht As Workbook, Bm As String
Dim Hx, Lx, Hx1, X, X2, arr
Dim Fd As FileDialog, Path As String
Application.ScreenUpdating = False
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
If Fd.Show = -1 Then Path = Fd.SelectedItems(1) & IIf(Right(Fd.SelectedItems(1), 1) = "", "", "") Else: Exit Sub
With Sheet1
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("A1").End(xlToRight).Column
arr = .Range(.Cells(1, 1), Cells(Hx, Lx))
For X = 2 To Hx
Bm = arr(X, 1)
For X2 = X + 1 To Hx
If arr(X2, 1) <> Bm Or X2 = Hx Then
If X2 = Hx Then
Hx1 = Hx
Else
Hx1 = X2 - 1
End If
GoTo Y
End If
Next
Y:
Set Sht = Workbooks.Add
Worksheets(1).Name = Bm
.Range(.Cells(1, 1), .Cells(1, Lx)).Copy Range("A1")
.Range(.Cells(X, 1), .Cells(Hx1, Lx)).Copy Range("A2")
ActiveWorkbook.SaveAs Path & Bm & ".xls", xlWorkbookDefault
ActiveWorkbook.Close
X = Hx1
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

sunjing-zxl · 发表于 2012-1-13 09:35

在给你传个附件
有两个注意事项：
1.数据源必须排序（按照“部门名称1“）
2.程序运行需要选择工作薄存放位置，这个要选择已有文件夹。（或则新建一个在存放）

apple_wong · 发表于 2012-1-13 09:53

呀，好迅速啊，谢谢sunjing-zxl
部门的名称只是需要排序，但各个部门不一定得按附件里的顺序吧？因为我还有好多部门名称没有列出来的。

雄鹰 · 发表于 2012-1-13 09:58

这种问题用随手发工具解决倒是不错的选择。

apple_wong · 发表于 2012-1-13 10:12

sunjing-zxl 发表于 2012-1-13 09:35
在给你传个附件
有两个注意事项：
1.数据源必须排序（按照“部门名称1“）

不行啊，怎么就弹出新建文件夹呢，还提示无效位置和有密码保护……

sunjing-zxl · 发表于 2012-1-13 10:23

选择原有文件不能输入文件名字，输入文件名字也要输入已经有的

sunjing-zxl · 发表于 2012-1-13 10:24

apple_wong 发表于 2012-1-13 09:53
呀，好迅速啊，谢谢sunjing-zxl
部门的名称只是需要排序，但各个部门不一定得按附件里的顺序吧？因为我还 ...

只是需要排序就行了，也就是一样的部门要在一起。顺序随便

sunjing-zxl · 发表于 2012-1-13 10:26

apple_wong 发表于 2012-1-13 10:12
不行啊，怎么就弹出新建文件夹呢，还提示无效位置和有密码保护……

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