ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1806|回复: 6

[已解决] 使用vba将汇总表拆分

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-12-30 15:45 | 显示全部楼层 |阅读模式
我是刚刚学习使用VBA的,我想把“汇总表”按班级拆分成独立的sheet,我的思路是先建以班级名称命名的sheet,再往相应的sheet中填内容,但是在建sheet的过程中会多出来好多未命名的sheet,不知为什么

Sub xinjiansheet()      '==================以C列的单元格内容新建
Dim d As Integer, sht As Worksheet
d = 3
Set sht = Worksheets("汇总表")
Do While sht.Cells(d, "C") <> ""
On Error Resume Next
    If Worksheets(sht.Cells(d, "C")) Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sht.Cells(d, "C").Value
    End If
    d = d + 1
Loop
End Sub
想请教一下我的问题出在什么地方了

年级成绩汇总表-请按班级拆分.rar

9.71 KB, 下载次数: 15

TA的精华主题

TA的得分主题

发表于 2013-12-30 15:53 | 显示全部楼层
因为出错的同时工作表已经新建了,按你的思路大致改了下:
  1. Sub xinjiansheet()      '==================以I列的单元格内容新建sheet
  2. Dim d As Integer, sht As Worksheet
  3. Application.ScreenUpdating = False
  4. Application.DisplayAlerts = False
  5. d = 3
  6. Set sht = Worksheets("汇总表")
  7. Do While sht.Cells(d, "C") <> ""
  8. On Error Resume Next
  9.     If Worksheets(sht.Cells(d, "C")) Is Nothing Then
  10.         Worksheets.Add after:=Worksheets(Worksheets.Count)
  11.         ActiveSheet.Name = sht.Cells(d, "C").Value
  12.         If Err.Number = 1004 Then ActiveSheet.Delete
  13.     End If
  14.     d = d + 1
  15. Loop
  16. Application.DisplayAlerts = True
  17. Application.ScreenUpdating = True
  18. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2013-12-30 15:56 | 显示全部楼层
你这个是循环创建新表的,
那个Do While loop,你好好看看条件的,

TA的精华主题

TA的得分主题

发表于 2013-12-30 16:19 | 显示全部楼层
  1. Sub test()
  2.   Dim cnn As New ADODB.Connection
  3.   Dim rs As New ADODB.Recordset
  4.   Dim sql As String
  5.   Dim mybook As String
  6.   Dim ws As Worksheet
  7.   Dim rng As Range
  8.   Application.DisplayAlerts = False
  9.   Application.ScreenUpdating = False
  10.   
  11.   mybook = ThisWorkbook.FullName
  12.   
  13.   For Each ws In Worksheets
  14.     If ws.Name <> "汇总表" Then
  15.       ws.Delete
  16.     End If
  17.   Next
  18.   Set rng = Worksheets("汇总表").Rows("1:2")
  19.   
  20.   With cnn
  21.     .Provider = "microsoft.jet.oledb.4.0"
  22.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
  23.     .Open
  24.   End With
  25.   sql = "select distinct 班级 from [汇总表$a2:h] where not isnull(班级)"
  26.   arr = Application.Transpose(Application.Transpose(cnn.Execute(sql).GetRows()))
  27.   For i = 1 To UBound(arr)
  28.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  29.     sql = "select * from [汇总表$a2:h] where 班级='" & arr(i) & "'"
  30.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
  31.     With ws
  32.       .Name = arr(i)
  33.       rng.Copy .Range("a1")
  34.       .Range("a3").CopyFromRecordset rs
  35.       r = .Cells(.Rows.Count).End(xlUp).Row
  36.       .Range("a2:h" & r).Borders.LineStyle = xlContinuous
  37.     End With
  38.     rs.Close
  39.   Next
  40.   cnn.Close
  41.   Set cnn = Nothing
  42.   Application.DisplayAlerts = True
  43.   Application.ScreenUpdating = True
  44. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2013-12-30 16:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Index <> 1 Then
      sht.Delete
    End If
Next
    Set d = CreateObject("scripting.dictionary") '后期绑定
    r = [c65536].End(3).Row '最大行数
    arr = Range("a3:h" & r) '数据区域放数组
    For i = 1 To UBound(arr) '数组维可用的最大下标循环
        bm = arr(i, 3) '关键字
        If Not d.Exists(bm) Then '判断关键词在字典里不存在
            Set d(bm) = Union(Rows("1:2"), Rows(i + 2)) '新关键字形成字典并且连接表头和对应行作为条目值
        Else
            Set d(bm) = Union(d(bm), Rows(i + 2)) '在已经有的字典连接已有条目和对应行作为条目值
        End If
    Next
    dk = d.Keys '关键字放数组
    dt = d.Items '条目放数组
    For i = 0 To UBound(dk) '对关键字个数循环
        Sheets.Add after:=Sheets(Sheets.Count) '添加工作表
        ActiveSheet.Name = dk(i) '
        dt(i).Copy ActiveSheet.[a1] '条目拷贝到工作表
    Next
Application.DisplayAlerts = True
End Sub

TA的精华主题

TA的得分主题

发表于 2013-12-30 16:22 | 显示全部楼层
本帖最后由 chxw68 于 2013-12-30 16:24 编辑

刚做完这样一道题,修改后顺便发了上来,供参考。从提取班级名称到生成班级表格都是用ADO+SQL完成,一气呵成,比较简练。

分解班级成绩.rar

14.63 KB, 下载次数: 47

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-6-20 10:12 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ADO及字典拆分工作表
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-26 03:03 , Processed in 0.037504 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表