高人请入，excel救急，关于工作表分拆VBA

  • x
    xin.h
    需要把一个工作表按D列中的项目分拆成多个表格，在网上搜了一圈，找到一个可用的实例，但是按A列分拆的，我想把宏修改成D列分拆，但无法实际，修改后新工作表复制的数据不完整。帮忙看看VBA代码怎么修改。

    应该实现的效果
    1.PNG



    运行宏后的效果
    2.PNG
  • c
    carter071
    代码能发一下吗 家里电脑装的wps 宏不好用 懒得装office了
  • x
    xin.h
    1. Private Sub CommandButton1_Click()
    2. Dim d As New Dictionary '字典,引用Microsoft Scripting Runtime
    3. Dim cn As New ADODB.Connection 'ADO,引用Microsoft ActiveX Data Objects 2.x Library
    4. Dim rst As New ADODB.Recordset
    5. Dim i&, n%, LastRow&, arr, rng As Range, sh As Worksheet
    6. Dim sql$, ThisSheetName$
    7. Set rng = Range("A1:AA2")
    8. ThisSheetName = Me.Name '工作表名
    9. LastRow = Range("A65536").End(xlUp).Row - 1 'A列最后单元格的行号
    10. arr = Range("d1:d" & LastRow) '原来是A1:A 我修改成D列
    11. Application.ScreenUpdating = False '关闭屏幕刷新

    13. For i = 3 To LastRow '循环A列
    14. d(arr(i, 1)) = 0 '添加到字典
    15. Next
    16. Application.DisplayAlerts = False
    17. For Each sh In Sheets
    18. If d.Exists(sh.Name) Then sh.Delete
    19. Next
    20. Application.DisplayAlerts = True


    23. cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName '打开链接

    25. For n = 0 To d.Count - 1
    26. sql = "select * from [" & ThisSheetName & "$d3:aa" & LastRow & "] where f1='" & d.Keys(n) & "'" '设置SQL语句 原来为a3:aa 我修改成D3列
    27. Set rst = cn.Execute(sql)

    29. Worksheets.Add(after:=Sheets(Sheets.Count)).Name = d.Keys(n)

    31. With ActiveSheet
    32. rng.Copy .Range("A1")


    35. .Range("A3").CopyFromRecordset rst '复制查询结果
    36. End With
    37. Next

    39. rst.Close: Set rst = Nothing
    40. cn.Close: Set cn = Nothing: Set d = Nothing
    41. Me.Activate
    42. Application.ScreenUpdating = True
    43. End Sub
    复制代码
    回复2#carter071
  • x
    xin.h
    还是没弄好
  • 交
    交通银行
    mark下，我最近也在搞这个。
  • l
    ljq29
    没看懂
    你咋把皮鞋拆分出2417的？HiPDA怪兽版
  • f
    fuqiang659
    前两天用了npoi发现比vba好用多了
  • z
    zhihuiwang100
    不懂，我也需要用，mark下
  • w
    wwwEagle
    导入到Access，想干啥都行。
  • z
    zhihuiwang100
    谢谢，mark
  • c
    cjzstc
    注释太少了，变量命名也很随意，看着就头疼
  • q
    qq149971093
    第二集还是第三集就可以解决问题，而且代码也比上面的简单。
  • n
    nostoryboy
    把表放到BI里会快很多吧
  • z
    z45680338
    马克一下
  • c
    cxbdemail
    $d3:aa改成$d3:d
  • 大
    大部头书
    1. Sub SplitToSheet()
    2. Sheets(1).Select
    3. Set l3 = Application.InputBox("请选择需要拆分的列", "选择列", "", , , , , 8)
    4. Application.ScreenUpdating = False
    5. Set d = CreateObject("scripting.dictionary")
    6. arr = Sheets(1).UsedRange
    7. For j = 2 To UBound(arr)
    8. If d.exists(arr(j, l3.Column)) Then
    9. Set d(arr(j, l3.Column)) = Union(d(arr(j, l3.Column)), Sheets(1).Cells(j, l3.Column))
    10. Else
    11. Set d(arr(j, l3.Column)) = Union(Sheets(1).Cells(1, 1), Sheets(1).Cells(j, l3.Column))
    12. End If
    13. Next j
    14. For j = 0 To d.Count - 1
    15. Sheets.Add after:=Sheets(Sheets.Count)
    16. Sheets(Sheets.Count).Name = d.keys()(j)
    17. d.items()(j).EntireRow.Copy Sheets(Sheets.Count).Cells(1, 1)
    18. Next j
    19. Application.ScreenUpdating = True
    20. Sheets(1).Select
    21. End Sub
    复制代码
  • m
    mch200438
    你应该发个你没修改过的版本吧，不然不是还得帮你先纠错
  • x
    xin.h
    感谢！这个是13年的帖子，问题解决了
  • 2
    2Bpencil
    pilot chart筛选后可以自动拆成多个表，楼主要不找教程学学