|
20学分
本帖最后由 tayisha 于 2012-3-1 17:06 编辑
这个一个拆分工作簿的问题,要求将《目录》拆分成两种方式,如《签约公司分表》或《责任公司分表》,原来有个代码文件也附在后面了,但是不满足现在的需求,按哪个字段拆分最好设成变量,这样很多相同情况就可以使用了,代码最好带注释。
经过花花老师指点之后稍作修改了代码
- 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)
|
|