如何将一表拆分为多表？

w_hb · 发表于 2012-9-9 10:13

请问如何将一个表格，按G列内容分拆分为多个表格（新建一个工作薄），并且所拆分的表格与原表格保持一致的格式（包括行高、列宽），若“仓库”为空则在所有拆分的表上都保存该条记录，若G列仓库为同一仓库（为空也可视为同一仓库），则不拆分，最后将仓库名按工作表分别填列在C3单元格。谢谢！

一表分多表.rar (14.21 KB, 下载次数: 342)

hustnzj · 发表于 2012-9-9 10:33

Sub ts()
Dim i&, j&, k&, ar, d As Object, dk, rng As Range
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
Set d = CreateObject("Scripting.Dictionary")
ar = [A6].CurrentRegion
For i = 2 To UBound(ar)
d(ar(i, 7)) = ""
Next i
dk = d.keys
For j = 0 To d.Count - 1
If Len(dk(j)) > 0 Then
Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = dk(j)
.[C3] = dk(j)
For k = 7 To UBound(ar) + 5
If Len(.Cells(k, 7).Value) Then
If .Cells(k, 7).Value <> dk(j) Then
If rng Is Nothing Then
Set rng = .Cells(k, 7)
Else
Set rng = Union(rng, .Cells(k, 7))
End If
End If
End If
Next k
rng.EntireRow.Delete
Set rng = Nothing
End With
End If
Next j
Set d = Nothing
End Sub

复制代码

hustnzj · 发表于 2012-9-9 10:34

附件……………………………………

w_hb · 发表于 2012-9-9 10:59

谢谢hustnzj，现在还有一个问题如果我是希望拆分的工作表新建成为一个工作薄，按现在的VBA ，如果我的工作薄里面有多个表的话，其他的表就都被下面的语句给删除了，
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
另外，新建的工作表的序号应该重新排列，谢谢

hustnzj · 发表于 2012-9-9 11:59

w_hb 发表于 2012-9-9 10:59
谢谢hustnzj，现在还有一个问题如果我是希望拆分的工作表新建成为一个工作薄，按现在的VBA ，如果我的工作 ...

楼主，到底是要新建工作簿，还是工作表？如果是工作簿，“新建的工作表的序号应该重新排列”这个就不成立了……

w_hb · 发表于 2012-9-9 12:11

我是希望将待拆分的工作表，拆分为多个表后保存到一个新建的工作薄里面，然后在每个工作表的A列重新填列序号（因原始工作表已经按B列排序了，故这里只需要在A列重新填写序号1、2、3、4、5.........就可以了

w_hb · 发表于 2012-9-10 22:14

继续顶起，期待更好的解决方案中............

w_hb · 发表于 2012-9-9 21:43

顶起，期待老师完善.....

hustnzj · 发表于 2012-9-12 13:25

w_hb 发表于 2012-9-10 22:14
继续顶起，期待更好的解决方案中............

Sub ts()
Dim i&, j&, k&, ar, d As Object, dk, rng As Range, wb As Workbook
Set d = CreateObject("Scripting.Dictionary")
ar = [A6].CurrentRegion
For i = 2 To UBound(ar)
d(ar(i, 7)) = ""
Next i
dk = d.keys
Set wb = Workbooks.Add(xlWBATWorksheet)
For j = 0 To UBound(dk)
If Len(dk(j)) > 0 Then
ThisWorkbook.Sheets("Sheet1").Copy after:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = dk(j)
.[C3] = dk(j)
For k = 7 To UBound(ar) + 5
If Len(.Cells(k, 7).Value) Then
If .Cells(k, 7).Value <> dk(j) Then
If rng Is Nothing Then
Set rng = .Cells(k, 7)
Else
Set rng = Union(rng, .Cells(k, 7))
End If
End If
End If
Next k
rng.EntireRow.Delete
Set rng = Nothing
.[A7] = 1
.[A7].AutoFill Destination:=.[A7].Resize(.Cells(Rows.Count, 1).End(3).Row - 6, 1), Type:=xlFillSeries
End With
End If
Next j
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
Set d = Nothing
Set wb = Nothing
End Sub

复制代码

hustnzj · 发表于 2012-9-12 13:25

附件………………

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

[求助] 如何将一表拆分为多表？

评分