ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 将一个表格按类型拆分为多个工作簿运行的时候出现问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-8-27 11:07 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
这个是一个将一个表格按类型拆分为多个工作簿运行的时候出现问题(标红的代码),不知道什么原因啊2016版64位excel,老师帮忙解决下

Sub CFGZB()

    Dim myRange As Variant

    Dim myArray

    Dim titleRange As Range

    Dim title As String

    Dim columnNum As Integer

    myRange = Application.InputBox(prompt:="请选择标题行:", Type:=8)

    myArray = WorksheetFunction.Transpose(myRange)

    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头,必须是第一行,且为一个单元格,如:“姓名”", Type:=8)

    title = titleRange.Value

    columnNum = titleRange.Column

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Dim i&, Myr&, Arr, num&

    Dim d, k

    For i = Sheets.Count To 1 Step -1

        If Sheets(i).Name <> "数据源" Then

            Sheets(i).Delete

        End If

    Next i

    Set d = CreateObject("Scripting.Dictionary")

    Myr = Worksheets("数据源").UsedRange.Rows.Count

    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))

    For i = 1 To UBound(Arr)

        d(Arr(i, 1)) = ""

    Next

    k = d.keys

    For i = 0 To UBound(k)

        Set conn = CreateObject("adodb.connection")

        'conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        conn.Open "provider=microsoft.Ace.OLEDB.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName

        Sql = "select * from [数据源] where " & title & " = '" & k(i) & "'"

        Dim Nowbook As Workbook

        Set Nowbook = Workbooks.Add

        With Nowbook

            With .Sheets(1)

                .Name = k(i)

                For num = 1 To UBound(myArray)

                    .Cells(1, num) = myArray(num, 1)

                Next num

                .Range("A2").CopyFromRecordset conn.Execute(Sql)

            End With

        End With

        ThisWorkbook.Activate

        Sheets(1).Cells.Select

        Selection.Copy

        Workbooks(Nowbook.Name).Activate

        ActiveSheet.Cells.Select

        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        Application.CutCopyMode = False

        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)

        Nowbook.Close True

        Set Nowbook = Nothing

    Next i

    conn.Close

    Set conn = Nothing

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub

错误提示

错误提示

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-27 11:12 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
表格如下,请老师帮忙指点下。

数据源.rar

12.83 KB, 下载次数: 6

TA的精华主题

TA的得分主题

发表于 2018-8-27 11:37 | 显示全部楼层
tianzhe521 发表于 2018-8-27 11:12
表格如下,请老师帮忙指点下。

按列拆分工作表另存工作簿的实例那么多耶,非得用这个?

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-8-27 13:01 | 显示全部楼层
代码仅供测试参考  sql方法


数据源拆分sql123.rar (206.53 KB, 下载次数: 50)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-27 14:04 | 显示全部楼层
我从网上查了好多都说代码没什么问题但是为什么我用不了呢?

TA的精华主题

TA的得分主题

发表于 2018-8-27 14:27 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
呵呵  你把代码搞得太复杂了

TA的精华主题

TA的得分主题

发表于 2018-8-27 14:30 | 显示全部楼层
abc123281 发表于 2018-8-27 13:01
代码仅供测试参考  sql方法

sql = "select distinct 所属区域类型 from [数据源$a1:i" & r & "] where 所属区域类型 is not null" 这个要能用鼠标点选 或者提示框输入才好 这种是死板的 表格一变 又得修改代码 对于不懂sql语句的人没有一点用处

TA的精华主题

TA的得分主题

发表于 2018-8-27 15:02 | 显示全部楼层
送你一个通用性的
  1. Sub 快速拆分工作表()
  2. Dim t, d, arr As Variant, x&, k&, col_name$, col_num%, rows_start%, mypath$, sheet_name$
  3. ThisWorkbook.Sheets(1).Activate
  4. sheet_name = Application.InputBox("请输入要拆分的表格名称,如sheet1", 表格名称)
  5. col_name = Application.InputBox("请输入拆分依据成员所在的列,如a", 输入列名称)
  6. col_num = Range(col_name & 1).Column
  7. rows_start = Application.InputBox("请输入标题行下开始的第一行号,如2", 输入开始行号)
  8. Application.ScreenUpdating = False
  9. Application.Calculation = xlCalculationManual
  10. Dim min
  11. min = Timer
  12. Set d = CreateObject("scripting.dictionary")
  13. k = Sheets(sheet_name).UsedRange.CurrentRegion.Rows.Count - rows_start + 1
  14. arr = Range(col_name & rows_start & ":" & col_name & k)
  15. For x = rows_start + 1 To UBound(arr)
  16. d(arr(x, 1)) = ""
  17. Next x
  18. If d.exists("") Then
  19. d.Remove ""
  20. End If
  21. For Each t In d.keys
  22. Workbooks.Add
  23. mypath = ThisWorkbook.Path & "" & sheet_name & "_" & "拆分出的表格"
  24. If Dir(mypath, vbDirectory) = "" Then
  25. MkDir mypath
  26. End If
  27. Dim workbook_path As String
  28. workbook_path = ThisWorkbook.Path & "" & sheet_name & "_" & "拆分出的表格" & _
  29. sheet_name & "_" & t & ".xlsx"
  30. ActiveSheet.Name = t
  31. ThisWorkbook.Sheets(sheet_name).Rows(rows_start - 1).AutoFilter Field:=col_num, Criteria1:=t
  32. ThisWorkbook.Sheets(sheet_name).UsedRange.Copy ActiveSheet.Cells(1, 1)
  33. ActiveWorkbook.SaveAs workbook_path
  34. ActiveWorkbook.Close
  35. ThisWorkbook.Activate
  36. Next t
  37. Application.ScreenUpdating = True
  38. ThisWorkbook.Sheets(sheet_name).Rows(rows_start - 1).AutoFilter
  39. MsgBox "拆分完工作表,一共用时" & Timer - min & "秒!"
  40. Application.Calculation = xlCalculationAutomatic
  41. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2018-8-27 15:06 | 显示全部楼层
呵呵  既然你会  就写个通用的   灵活的代码发上来我们学习一下吧

TA的精华主题

TA的得分主题

发表于 2018-8-27 15:58 | 显示全部楼层
abc123281 发表于 2018-8-27 15:06
呵呵  既然你会  就写个通用的   灵活的代码发上来我们学习一下吧

sql 语句的 我不知道怎么让“”内的怎么才能 使用变量
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 22:52 , Processed in 0.057980 second(s), 15 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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