查看: 3367|回复: 1
如何用VBA把某单元格区域的内容或格式复制到工作簿中所有工作表的相同区域中？
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次管理次数 次
网站名称: Excel技巧网 | Excel专家栖息谷 | 微软中文技术社区合作伙伴
署名作者: gvntw
版权声明: 版权归本站与作者共有 除本站官方外非作者本人转载须经许可并注明出处
适用版本: 03以前版本&
语言环境: 简体中文
学习方法: 掌握Excel技巧的关键是动手操作
下载 ≠ 知识
免费注册成为本站会员，享用更多功能，结识更多Office办公高手！
才可以下载或查看，没有帐号？
Q：如何用VBA把某单元格区域的内容或格式复制到工作簿中所有工作表的相同区域中？
A：把A1:D10内容复制到工作簿中所有工作表的A1:D10中，代码如下：
Worksheets.FillAcrossSheets ([a1:D10]), xlContents
复制代码注：最后一个参数(type)根据要复制的内容决定，仅复制内容为 xlContents，仅复制格式为 xlFormats，全部复制为 xlAll，省略默认为 xlAll。
学office，哪能不关注全网最大的Office类微博（新浪）
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次管理次数 次
Sheets.FillAcrossSheets 方法
将单元格区域复制到集合中所有其他工作表的同一位置。
这个办法比循环的办法更快。
学office，哪能不关注全网最大的Office类微博（新浪）
站长推荐 /1
关注 微信号：exceltip_net
回复“教程”二字，即可下载。
Excel技巧网的会员探讨问题仅代表其个人意见，与网站的立场无关。任何违反国家和地方相关法律法规的言论，本站有义务协助政府相关部门追究发言者的责任！
本站中非注明转载文章与案例的版权为作者与Excel技巧网共有。若非原文作者，本站之外任何单位或个人未经允许，不得将其用于商业用途。
若非原文作者，任何形式的非商业性转载必须获得Excel技巧网或作者允许，并注明作者和出处。
会员发表的帖子如涉及版权纠纷，须自行负责。详情请参考注册时的网站服务条款。
本站特聘法律顾问：沈学律师
Powered by查看: 1812|回复: 24
提取上五行内各行红色填充数字在该行投影所对应的数字,按小大顺序放置在后面相应单元
阅读权限70
在线时间 小时
提取上五行内各行红色填充数字在该行&投影&所对应的数字,按小大顺序放置在后面相应单元格中.
比如,对于最末一行:其上方第一行即15行中,红色填充单元格在该行的&投影&对应的数字,分别为08 05 09 10,小大排序后为05 08 09 10,放置在后面AF列单元格中;其上方第二行即14行中,红色填充单元格在该行的&投影&对应的数字,分别为07 01 13 11,小大排序后为01 07 11 13,放置在后面AG列单元格中;……
请帮忙用代码实现，谢谢！
13:36 上传
点击文件名下载附件
13.03 KB, 下载次数: 21
阅读权限95
在线时间 小时
本帖最后由 zhaogang1960 于
14:20 编辑
请测试:Sub 宏1()
& & Dim i&, j&, arr(1 To 11), brr(), n&, s$
& & With Range(&Q5:AD16&)
& && &&&For i = 1 To 11
& && && && &ReDim brr(1 To 14)
& && && && &n = 0
& && && && &For j = 1 To 14
& && && && && & If .Cells(i, j).Interior.Color = 255 Then
& && && && && && &&&n = n + 1
& && && && && && &&&brr(n) = Val(.Cells(12, j).Value)
& && && && && & End If
& && && && &Next
& && && && &ReDim Preserve brr(1 To n)
& && && && &s = &&
& && && && &With WorksheetFunction
& && && && && & For j = 1 To n
& && && && && && &&&s = s & & & & Format(.Small(brr, j), &00&)
& && && && && & Next
& && && && &End With
& && && && &arr(i) = Mid(s, 2)
& && &&&Next
& & End With
& & [AF16].Resize(, 11) = arr
End Sub
阅读权限95
在线时间 小时
(24.51 KB, 下载次数: 30)
14:21 上传
点击文件名下载附件
阅读权限30
在线时间 小时
VBA真的很强大啊~~
领导说：一点什么都出来了，电脑真好，哈哈&
阅读权限70
在线时间 小时
zhaogang1960 发表于
谢谢,看了下,效果不错,有两个地方请帮忙再改进下:
1.对于最后一行的计算:
&&af列应该显示向上第一行,即倒数第二行.ag列显示上面第二行,即倒数第三行……以此类推
2.求向上五行的投影即可，不必求上方所有行的投影；
3.希望不单单求最末一行，而是求尽可能多的行的结果:即Q列的总行数-5
请版主再帮忙看下,谢谢!
阅读权限95
在线时间 小时
yinxingbaoshu 发表于
谢谢,看了下,效果不错,有两个地方请帮忙再改进下:
1.对于最后一行的计算:
&&af列应该显示向上第一行,即 ...
请上传附件说明
阅读权限30
在线时间 小时
ddhhyy16 发表于
VBA真的很强大啊~~
老师，帮我看看这个，将原始数据分别填入大东营业厅，大东第一营业厅~如何用VBA实现
15:48 上传
点击文件名下载附件
87.41 KB, 下载次数: 5
阅读权限95
在线时间 小时
ddhhyy16 发表于
老师，帮我看看这个，将原始数据分别填入大东营业厅，大东第一营业厅~如何用VBA实现Sub Macro1()
& & Dim d As Object, ds As Object, sh As Worksheet, a, arr, brr, i&, j&, l&, s$, t, temp$, ta, b As Boolean
& & Set d = CreateObject(&scripting.dictionary&) '创建字典对象
& & Set ds = CreateObject(&scripting.dictionary&) '创建字典对象
& & arr = Sheets(&原始数据&).Range(&A1&).CurrentRegion '数据写入数组
& & For i = 2 To UBound(arr) '逐列数据
& && &&&If Len(arr(i, 2)) Then '如果营业厅列不为空
& && && && &If Not d.Exists(arr(i, 2)) Then Set d(arr(i, 2)) = CreateObject(&scripting.dictionary&) '创建该营业厅字典对象
& && && && &If Len(arr(i, 3)) = 4 Then '如果科目编码为4位数，即为一级科目
& && && && && & d(arr(i, 2))(arr(i, 4)) = d(arr(i, 2))(arr(i, 4)) & &,& & i '一级科目对应的“科目名称”添加到字典键值，即字典记住行号
& && && && && & temp = arr(i, 4) '一级科目对应的“科目名称”
& && && && &Else '二级科目
& && && && && & d(arr(i, 2))(temp & arr(i, 4)) = d(arr(i, 2))(temp & arr(i, 4)) & &,& & i ''一级科目对应的“科目名称”和二级科目连接后添加到字典键值，字典记住行号
& && && && &End If
& && &&&End If
& & Next
& & k = d.Keys '字典键值写入数组k，即不重复的营业厅
& & On Error Resume Next '避免不重复的营业厅对应的工作表不存在时出错提示
& & For l = 0 To d.Count - 1 '逐个营业厅
& && &&&Set sh = Sheets(k(l)) '把该营业厅工作表赋值给变量sh
& && &&&If Not sh Is Nothing Then '
& && && && &With sh.Range(&A1&).CurrentRegion '分表数据区域
& && && && && & .Offset(3, 3).ClearContents '清除原数据
& && && && && & brr = .Value '写入数组
& && && && && & For j = 4 To UBound(brr, 2) Step 2
& && && && && && &&&ds(Replace(brr(2, j), &月&, &&)) = j
& && && && && & Next
& && && && && & For i = 4 To UBound(brr) '逐行
& && && && && && &&&If Len(brr(i, 1)) & 2 Then '如果第一列不为空，即为一级科目
& && && && && && && && &s = brr(i, 1) '临时变量记住一级科目
& && && && && && && && &temp = s '同上
& && && && && && && && &b = True
& && && && && && &&&Else '二级科目
& && && && && && && && &s = temp & brr(i, 3) '一级科目连接二级科目
& && && && && && && && &b = False
& && && && && && &&&End If
& && && && && && &&&t = d(k(l))(s) '字典条目
& && && && && && &&&If t && && Then '字典存在
& && && && && && && && &a = Split(t, &,&) '拆分行号
& && && && && && && && &For j = 1 To UBound(a) '逐个行号
& && && && && && && && && & brr(i, ds(&& & arr(a(j), 1))) = arr(a(j), 7)&&'月份对应的列写入辅助列数值
& && && && && && && && && & If b Then
& && && && && && && && && && &&&ta = arr(a(j), 7)
& && && && && && && && && & Else
& && && && && && && && && && &&&If ta & 0 Then brr(i, ds(&& & arr(a(j), 1)) + 1) = arr(a(j), 7) / ta
& && && && && && && && && & End If
& && && && && && && && &Next
& && && && && && &&&End If
& && && && && & Next
& && && && && & .Value = brr '处理后的数组写回数据区域
& && && && &End With
& && &&&End If
& & Next
End Sub
复制代码
阅读权限95
在线时间 小时
“大东第一营业厅”工作表中缺少了扶助列，下面代码已经添加：
(73.75 KB, 下载次数: 11)
16:37 上传
点击文件名下载附件
阅读权限30
在线时间 小时
本帖最后由 ddhhyy16 于
17:43 编辑
zhaogang1960 发表于
“大东第一营业厅”工作表中缺少了扶助列，下面代码已经添加：
哦赛，老师，你好厉害，这个表格我需要一天的功夫才能整理好，居然一键就完成了~
玩命加载中，请稍候
玩命加载中，请稍候
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
本站特聘法律顾问：徐怀玉律师 李志群律师
Powered by查看: 1252|回复: 5
根据选定区域，填充序列数字并排序
阅读权限20
在线时间 小时
请看解释图片
1.jpg (45.12 KB, 下载次数: 0)
07:49 上传
2.jpg (48.3 KB, 下载次数: 0)
07:49 上传
3.jpg (44.56 KB, 下载次数: 0)
07:49 上传
4.jpg (44.81 KB, 下载次数: 0)
07:49 上传
(8.81 KB, 下载次数: 10)
07:49 上传
点击文件名下载附件
阅读权限95
在线时间 小时
& & & & & & & &
Public Sub fill1()
Dim x As Range, n
n = Application.Max(Range([a1], [a65536].End(3)).Offset(, 2)) + 1
For Each x In Selection.Rows
& & Cells(x.Row, 3) = n
阅读权限95
在线时间 小时
没看到排序。
阅读权限95
在线时间 小时
所谓排序可能就是指&&按照序列自动填充
没有说明白
阅读权限20
在线时间 小时
谢谢，可以用了，速度能再提升点吗？似乎有点慢
阅读权限95
在线时间 小时
Public Sub fill2()
Dim x As Range, n, rng As Range
n = Application.Max(Range([a1], [a65536].End(3)).Offset(, 2)) + 1
For Each x In Selection.Rows
& & If rng Is Nothing Then Set rng = Cells(x.Row, 3) Else Set rng = Union(rng, Cells(x.Row, 3))
& & If Not rng Is Nothing Then rng = n
玩命加载中，请稍候
玩命加载中，请稍候
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
本站特聘法律顾问：徐怀玉律师 李志群律师
Powered by请问用VBA控制Excel填充单元格内容，若一行满了如何将剩余内容自动到下一行
[问题点数：0分]
请问用VBA控制Excel填充单元格内容，若一行满了如何将剩余内容自动到下一行
[问题点数：0分]
不显示删除回复
显示所有回复
显示星级回复
显示得分回复
只显示楼主
相关帖子推荐：
本帖子已过去太久远了，不再提供回复功能。