设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

返回列表 发新帖
查看: 657|回复: 1
打印 上一主题 下一主题

excl数据分类代码求教!

[复制链接]
跳转到指定楼层
1#
发表于 2023-7-10 10:33:30 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
把sheet1的数据按班级复到各自工作表中,代码死循环了,求教高手!

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅
2#
发表于 2023-7-13 21:58:28 | 只看该作者
楼主的思路估计是想一行行复制粘贴。但这里有一个问题需要解决:粘贴完每一行,都需要记录被粘贴的位置,否则下次粘贴就会出现空行。

这样说可能有些难以理解。打个比方:
第一次,复制数据源的第2行,粘贴到工作表“1”的第2行,这时候记下这个位置A。
第二次,复制第3行,粘贴到工作表“2”的第2行,再记下这个位置B。
第三次,复制第4行,粘贴到工作表“1”的位置A的下一行,并更新位置A。
…………
这只是2个工作表,就要记下2个位置,不仅需要避免混淆,还需要更新。
因此如果一行行复制,需要定义一个字典或者集合,以工作表名称为键名(key),以位置作为键值(value),才能完成这个任务。
个人觉得比较复杂,因此采用一种更加方便的做法,就是使用自动筛选,根据筛选值的个数复制粘贴,这样的话,相对来说,效率也会高一些,逐行复制粘贴20次,但自动筛选只有2次。而且不容易混淆。毕竟一个班只会复制粘贴一次。
代码如下:
  1. Sub feilei()


  2.     Dim lngRows As Long
  3.     Dim i As Long
  4.     Dim lngClass As Long
  5.     Dim dict As New Dictionary
  6.     Dim key As Variant
  7.     '获取行数
  8.     lngRows = Sheet1.UsedRange.Rows.Count
  9.    
  10.    
  11.     '筛选不重复班级,丢进字典里,用于后续筛选
  12.     For i = 2 To lngRows
  13.         lngClass = Sheet1.Range("C" & i)
  14.         If Not dict.Exists(lngClass) Then
  15.             dict(lngClass) = ""
  16.         End If
  17.     Next
  18.    
  19.    
  20.    
  21.     For Each key In dict.Keys
  22.     '激活工作表
  23.         Sheet1.Activate
  24.     '筛选数据
  25.         Sheet1.Range("A1:G" & lngRows).AutoFilter 3, key
  26.     '复制筛选结果
  27.         Sheet1.Range("A2:G" & lngRows).Select
  28.         Selection.Copy
  29.         For i = 1 To Sheets.Count
  30.         '如果工作表名称和筛选条件相同(由于name是文本类型,因此需要使用cstr转为文本,否则将无法粘贴或者报错)
  31.             If Sheets(i).Name = CStr(key) Then
  32.                 Sheets(i).Activate
  33.                 '激活A2单元格
  34.                 Sheets(i).Range("A2").Activate
  35.                 '粘贴数据后跳出循环,可以减少循环次数
  36.                 ActiveSheet.Paste
  37.                 Exit For
  38.             End If
  39.         Next
  40.     Next
  41.     '取消自动筛选
  42.     Sheet1.Range("A1:G" & lngRows).AutoFilter
  43.    
  44.    
  45. End Sub

复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

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

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-15 13:05 , Processed in 0.076826 second(s), 26 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

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