Question

excel用vba如何按某列对一个工作簿里的两个工作表进行分表拆成多个工作簿？

vba 一个工作簿有两个工作表，两个表有同样的一列（比如部门名称），按这列（部门名称）同时对两个工作表进行分表，每个部门一个工作簿，里面有这个部门的两个表数据，怎么实现。





Answer 1

这下子明白了，部门都在A列，表头只有一行，代码如下图：

下面的文字仅供参考，浏览器可能会偷吃字符：

Option Explicit

Sub 拆分()
Dim depts, dept, arr, i, j, st, wb, st2
Set depts = CreateObject("scripting.dictionary")
'第一次扫描，获得所有部门清单
For Each st In Sheets
arr = st.UsedRange
For i = 2 To UBound(arr)
dept = Trim(arr(i, 1))
If dept <> "" Then depts(dept) = True
Next i
Next st
'第二次扫描，生产各部门文件
Set wb = ThisWorkbook
For Each dept In depts.keys
With Workbooks.Add
For Each st In wb.Sheets
arr = st.UsedRange
Set st2 = .Sheets.Add(after:=.Sheets(.Sheets.Count))
st2.Name = st.Name
j = 0
For i = 1 To UBound(arr)
If i = 1 Or Trim(arr(i, 1)) = dept Then
j = j + 1
st.Rows(i).Copy st2.Rows(j)
End If
Next i
Next st
.SaveAs wb.FullName & "." & dept & ".xlsx"
.Close
End With
Next dept
End Sub

追问

For i = 2 To UBound(arr) 这行就开始报错了，能帮忙试下吗

追答

这是因为你的工作簿里面有空表

Answer 2

Option Explicit

Sub 按部门分表()'各个部门是连续的
Dim s As Long, infor
Dim i As Long
Dim Bool As Boolean
With ThisWorkbook.Worksheets("人员信息")
Bool = True
s = 2
For i = 2 To .Range("A" & .Cells.Rows.Count).End(xlUp).Row + 1
If Bool Then
infor = .Cells(s, 1)
Bool = False
End If
If .Cells(i, 1) <> infor Then
Workbooks.Add
.Rows("1:1").Copy ActiveWorkbook.Sheets(1).Range("A1")
.Rows(s & ":" & i - 1).Copy ActiveWorkbook.Sheets(1).Range("A2")
ActiveWorkbook.SaveAs Filename:="C:\Users\qq196\Desktop\123\" & .Cells(i - 1, 1) & ".xlsx"
ActiveWorkbook.Close
s = i
Bool = True
End If
Next i
End With
End Sub