Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2666|回复: 4

[已解决]指定表分类列出数据

[复制链接]
发表于 2014-11-1 17:54 | 显示全部楼层 |阅读模式

现有一包含多张工作表的工作簿,其中表sheet8和sheet9行数相同(表头都占3行)且适用同一分类规则,则复制生成N个工作簿,每个工作簿的sheet8和sheet9仅包含一种分类内容,保留表头,其他表保持不变。本人VBA小白,求大神出手!

最佳答案
2014-11-2 06:24
  1. Sub Macro1()
  2. Dim wb As Workbook, d, i&, h&, l%, j&
  3. Application.ScreenUpdating = False
  4. Application.DisplayAlerts = False
  5. Set d = CreateObject("scripting.dictionary")
  6. Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
  7. arr = wb.Sheets("Sheet8").Range("a3").CurrentRegion
  8. h = UBound(arr): l = UBound(arr, 2)
  9. For i = 4 To h
  10.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
  11. Next
  12. wb.Close 0
  13. a = d.keys: b = d.items
  14. For i = 0 To d.Count - 1 '另存为工作簿
  15.     Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
  16.     Application.Windows(wb.Name).Visible = True
  17.     wb.SaveAs Filename:=ThisWorkbook.Path & "" & a(i) & ".xls"
  18.     With Workbooks(a(i))
  19.         For j = h To 4 Step -1
  20.             If InStr(b(i) & ",", "," & j & ",") = 0 Then
  21.                  .Sheets("sheet8").Rows(j).Delete
  22.                  .Sheets("sheet9").Rows(j).Delete
  23.             End If
  24.         Next
  25.         .Close 1
  26.     End With
  27. Next
  28. Application.DisplayAlerts = True
  29. Application.ScreenUpdating = True
  30. End Sub
复制代码

指定表数据分类列出.zip

37.66 KB, 下载次数: 15

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2014-11-2 06:24 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim wb As Workbook, d, i&, h&, l%, j&
  3. Application.ScreenUpdating = False
  4. Application.DisplayAlerts = False
  5. Set d = CreateObject("scripting.dictionary")
  6. Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
  7. arr = wb.Sheets("Sheet8").Range("a3").CurrentRegion
  8. h = UBound(arr): l = UBound(arr, 2)
  9. For i = 4 To h
  10.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
  11. Next
  12. wb.Close 0
  13. a = d.keys: b = d.items
  14. For i = 0 To d.Count - 1 '另存为工作簿
  15.     Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
  16.     Application.Windows(wb.Name).Visible = True
  17.     wb.SaveAs Filename:=ThisWorkbook.Path & "" & a(i) & ".xls"
  18.     With Workbooks(a(i))
  19.         For j = h To 4 Step -1
  20.             If InStr(b(i) & ",", "," & j & ",") = 0 Then
  21.                  .Sheets("sheet8").Rows(j).Delete
  22.                  .Sheets("sheet9").Rows(j).Delete
  23.             End If
  24.         Next
  25.         .Close 1
  26.     End With
  27. Next
  28. Application.DisplayAlerts = True
  29. Application.ScreenUpdating = True
  30. End Sub
复制代码
回复

使用道具 举报

发表于 2014-11-2 06:26 | 显示全部楼层
………………

Downloads.zip

13.68 KB, 下载次数: 23

回复

使用道具 举报

 楼主| 发表于 2014-11-2 12:45 | 显示全部楼层
感谢dsmch老师完美的解决了我的问题,希望自己以后也能成为您一样的高手。谢谢!
回复

使用道具 举报

 楼主| 发表于 2014-11-2 16:19 | 显示全部楼层
本帖最后由 joyzlxsjay 于 2014-11-2 16:29 编辑
dsmch 发表于 2014-11-2 06:26
………………

dsmch老师,我将您给出的代码应用到另一工作簿上为什么会出现"下标越界"问题呢,劳烦您再帮忙查看下。 下标越界错误.zip (86.1 KB, 下载次数: 0)
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 19:39 , Processed in 0.432228 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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