Excel精英培训网

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

[已解决]复制转置的VBA

[复制链接]
发表于 2017-8-9 19:34 | 显示全部楼层 |阅读模式
复制转置的VBA
最佳答案
2017-8-10 09:32
  1. Sub aaa()
  2. If Selection.Count > 1 Then Exit Sub
  3. If Intersect(Selection, [d17].CurrentRegion) Is Nothing Then Exit Sub
  4. If Intersect(Selection.Offset(, 1), [d17].CurrentRegion) Is Nothing Then Exit Sub
  5. If Intersect(Selection.Offset(, -1), [d17].CurrentRegion) Is Nothing Then Exit Sub
  6. Selection.Offset(, -1).Resize(, 3).Copy
  7. Cells(27, Selection.Column - 1).Resize(3, 3).PasteSpecial Transpose:=True
  8. End Sub
复制代码

tt.rar

8.7 KB, 下载次数: 29

发表于 2017-8-10 09:32 | 显示全部楼层    本楼为最佳答案   
  1. Sub aaa()
  2. If Selection.Count > 1 Then Exit Sub
  3. If Intersect(Selection, [d17].CurrentRegion) Is Nothing Then Exit Sub
  4. If Intersect(Selection.Offset(, 1), [d17].CurrentRegion) Is Nothing Then Exit Sub
  5. If Intersect(Selection.Offset(, -1), [d17].CurrentRegion) Is Nothing Then Exit Sub
  6. Selection.Offset(, -1).Resize(, 3).Copy
  7. Cells(27, Selection.Column - 1).Resize(3, 3).PasteSpecial Transpose:=True
  8. End Sub
复制代码
回复

使用道具 举报

发表于 2017-8-10 09:41 | 显示全部楼层
顺便把表2的代码也给你。
  1. Sub bbb()
  2. Dim rng As Range, rng1 As Range
  3. Set rng = Selection
  4. Set rng1 = [d17].CurrentRegion
  5. If rng.Count > 1 Then Exit Sub
  6. If Intersect(rng, rng1) Is Nothing Then Exit Sub
  7. If Intersect(rng.Offset(, 1), rng1) Is Nothing Then Exit Sub
  8. If Intersect(rng.Offset(, -1), rng1) Is Nothing Then Exit Sub
  9. Dim arr(2, 2), j&
  10. For j = 0 To 2
  11.   arr(1, j) = Selection.Offset(, j - 1)
  12.   arr(0, j) = IIf(arr(1, j) = 0, 9, arr(1, j) - 1)
  13.   arr(2, j) = IIf(arr(1, j) = 9, 0, arr(1, j) + 1)
  14. Next j
  15. Cells(19, Selection.Column - 1).Resize(3, 3) = arr
  16. End Sub
复制代码
回复

使用道具 举报

发表于 2019-4-17 12:55 | 显示全部楼层
大灰狼1976 发表于 2017-8-10 09:41
顺便把表2的代码也给你。

你这样的好人已经不多了
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 05:51 , Processed in 0.323716 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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