[已解决]拆分工作簿

tayisha · 发表于 2012-3-1 15:25

本帖最后由 tayisha 于 2012-3-1 17:06 编辑

这个一个拆分工作簿的问题，要求将《目录》拆分成两种方式，如《签约公司分表》或《责任公司分表》，原来有个代码文件也附在后面了，但是不满足现在的需求，按哪个字段拆分最好设成变量，这样很多相同情况就可以使用了，代码最好带注释。

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-3-2 13:48

经过花花老师指点之后稍作修改了代码

Sub 拆分工作表()
Dim d As New Dictionary
Dim sht As Worksheet, bm As String
Dim arr1, arr2, arr3, arr4, k As Long
Dim i As Long, j As Long, n As Long, m As Long
Application.ScreenUpdating = False '关闭屏幕更新
Application.DisplayAlerts = False '关闭特定的警告和消息
k = InputBox("请输正整数", "输入表头行数") '标题区域的行数赋值给变量k
'不加with语句就跟拆分的工作表名无关,可以任意修改拆分的工作表表名(但是不能在其他工作表中运行本程序)
'按照楼主要求用这个不加with的语句较好,就不怕修改工作表名了。
n = Range("IV3").End(xlToLeft).Column
m = Range("A65536").End(xlUp).Row
arr1 = Range(Cells(1, 1), Cells(k, n))
arr2 = Range(Cells(k + 1, 1), Cells(m, n))
'下面是加了with语句的写法(这样写就要固定工作表名,可以在任意工作表中运行本程序)
' With Sheets("总目录")
' n = .Range("IV3").End(xlToLeft).Column '记录《总目录》表最后一列列号
' m = .Range("A65536").End(xlUp).Row '记录《总目录》表最后一行行号
' arr1 = .Range(.Cells(1, 1), .Cells(k, n)) '标题区域赋值给数组arr1
' arr2 = .Range(.Cells(k + 1, 1), .Cells(m, n)) '数据区域赋值给数组arr2
' End With
k = InputBox("请输入按列拆分的列号", "输入列号的数字") '将需要拆分的标准列号赋值给变量k
ReDim arr3(1 To UBound(arr2), 1 To UBound(arr2, 2)) '重新定义arr3储备拆分后的数据
For i = 1 To UBound(arr2) '循环处理数组arr2
If Len(Trim(arr2(i, k))) Then '如果数组arr2不为空（既k数字对应的列不为空）则：
If d.Exists(arr2(i, k)) Then
arr4 = d(arr2(i, k))(0) '字典key存在就把对应的item的arr3赋值给数组arr4
n = d(arr2(i, k))(1) + 1 'item的定位数字累加1
For j = 1 To UBound(arr2, 2)
arr4(n, j) = arr2(i, j) '循环将arr2的第i行数据赋值给数组arr4的第n行(即新增列)
Next j
'将新增加的数据从新作为字典的item值赋值给字典
d(arr2(i, k)) = Array(arr4, n)
Else
'如果字典key不存在就将该行数据(arr2当前循环行的内容)赋值给数组arr3
For j = 1 To UBound(arr2, 2)
arr3(1, j) = arr2(i, j) '循环将arr2的第i行数据赋值给数组arr3的第1行
Next j
'建立字典key(对应列的公司名称),赋值item(arr3为当前循环行的数据,1为定位数字)
d.Add arr2(i, k), Array(arr3, 1)
End If
End If
Next i
If d.Count > 0 Then '如果字典个数大于0
For i = 1 To d.Count '在字典中循环处理数据
bm = d.Keys(i - 1) '字典的key(即公司名字)赋值给bm(即新建工作表名)
arr4 = d.Items(i - 1)(0) '字典的item第一个数据(即改key值的数据)赋值给数组arr4
'容错循环,如果工作薄存将建立的工作表则先删除(花花老师指点后增加)
For j = 1 To Sheets.Count
If Sheets(j).Name = bm Then
Sheets(j).Delete
Exit For '同一个工作簿不会出现多个相同的工作表名,因此只要删除一个就直接退出循环
End If
Next j
Set sht = Sheets.Add
sht.Name = bm
With Sheets(bm)
.Range("A1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
'这里用d(bm)(1)就是字典item的定位数字,也就是数据的有效行数,用ubound(arr4)也可以,只是这个行数就是一个较大的数字。
'd(bm)(1)花花老师指点后修改
.Range("A" & UBound(arr1) + 1).Resize(d(bm)(1), UBound(arr4, 2)) = arr4
End With
Next i
End If
Application.ScreenUpdating = True '成对使用程序运行时关闭,完成后开启
Application.DisplayAlerts = True '成对使用程序运行时关闭,完成后开启
Set d = Nothing '释放字典
End Sub

复制代码

附件： (, 下载次数: 8)

zjcat35 · 发表于 2012-3-1 15:29

附件啊没有看到

从从容容 · 发表于 2012-3-1 15:49

没有附件，谁会明白呀？

fay_france · 发表于 2012-3-1 15:55

楼主这问题~~~没头没尾哦

tayisha · 发表于 2012-3-1 17:06

一忙，忘了传附件了，呵呵

tayisha · 发表于 2012-3-1 17:08

zjcat35 发表于 2012-3-1 15:29
附件啊没有看到

传了{:241:}{:321:}

keyan2003 · 发表于 2012-3-1 17:08

不会..............观望

keyan2003 · 发表于 2012-3-1 17:09

不会..............观望了

sunjing-zxl · 发表于 2012-3-2 10:08

Sub 拆分工作表()
Dim d As New Dictionary
Dim sht As Worksheet, bm As String
Dim arr1, arr2, arr3, arr4, k As Long
Dim i As Long, j As Long, n As Long, m As Long
Application.ScreenUpdating = False
With Sheets("总目录")
n = .Range("IV3").End(xlToLeft).Column '记录《总目录》表最后一列列号
m = .Range("A65536").End(xlUp).Row '记录《总目录》表最后一行行号
arr1 = .Range(.Cells(1, 1), .Cells(3, n)) '标题区域赋值给数组arr1
arr2 = .Range(.Cells(4, 1), .Cells(m, n)) '数据区域赋值给数组arr2
End With
k = InputBox("请输入按列拆分的列号", "输入列号的数字") '将需要拆分的标准列号赋值给变量
ReDim arr3(1 To UBound(arr2), 1 To UBound(arr2, 2)) '重新定义arr3储备拆分后的数据
For i = 1 To UBound(arr2) '循环处理数组arr2
If Len(Trim(arr2(i, k))) Then '如果数组arr2不为空（既k数字对应的列不为空）则：
If d.Exists(arr2(i, k)) Then
arr4 = d(arr2(i, k))(0) '字典key存在就把对应的item的arr3赋值给数组arr4
n = d(arr2(i, k))(1) + 1 'item的定位数字累加1
For j = 1 To UBound(arr2, 2)
arr4(n, j) = arr2(i, j) '循环将arr2的第i行数据赋值给数组arr4的第n行(即新增列)
Next j
'将新增加的数据从新作为字典的item值赋值给字典
d(arr2(i, k)) = Array(arr4, n)
Else
'如果字典key不存在就将该行数据(arr2当前循环行的内容)赋值给数组arr3
For j = 1 To UBound(arr2, 2)
arr3(1, j) = arr2(i, j) '循环将arr2的第i行数据赋值给数组arr3的第1行
Next j
'建立字典key(对应列的公司名称),赋值item(arr3为当前循环行的数据,1为定位数字)
d.Add arr2(i, k), Array(arr3, 1)
End If
End If
Next i
If d.Count > 0 Then '如果字典个数大于0
For i = 1 To d.Count '在字典中循环处理数据
bm = d.Keys(i - 1) '字典的key(即公司名字)赋值给bm(即新建工作表名)
arr4 = d.Items(i - 1)(0) '字典的item第一个数据(即改key值的数据)赋值给数组arr4
Set sht = Sheets.Add
sht.Name = bm
With Sheets(bm)
.Range("A1").Resize(3, UBound(arr1, 2)) = arr1
.Range("A4").Resize(UBound(arr4), UBound(arr4, 2)) = arr4
End With
Next i
End If
Application.ScreenUpdating = True
Set d = Nothing
End Sub

复制代码

附件：

目录.rar (13.61 KB, 下载次数: 13)

tayisha · 发表于 2012-3-2 11:36

sunjing-zxl 发表于 2012-3-2 10:08
附件：
这个是拆分工作表的，要拆分工作薄就完全可以按照你附件里面的代码拆分了

还是孙博对我好，呵呵

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

[已解决]拆分工作簿

相关帖子