设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 通过VBA实现 数据的分行
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 4802|回复: 11

[已解决]通过VBA实现 数据的分行

[复制链接]
sj_dcy
发表于 2015-9-11 14:26 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
能不能通过VBA 再另一个表格里实现对原数据的D列进行分行？其他列根据情况进行复制
最佳答案
月排行榜 / 总排行榜
gufengaoyue
2015-9-11 15:15
sj_dcy 发表于 2015-9-11 14:58
是的  刚才测试 要是数据多的话 下面的的一些就没有边框了

现在不是有了吗？
  1. Sub XXX()
  2. Dim arr, brr, srr, a&, x&, s&
  3. arr = Range("a1").CurrentRegion
  4. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
  5. For a = 2 To UBound(arr)
  6.      If arr(a, 4) <> "" Then
  7.           srr = Split(arr(a, 4), ",")
  8.           For s = 0 To UBound(srr)
  9.                x = x + 1
  10.                brr(x, 1) = arr(a, 1)
  11.                brr(x, 2) = arr(a, 2)
  12.                brr(x, 3) = arr(a, 3)
  13.                brr(x, 4) = srr(s)
  14.           Next
  15.      End If
  16. Next
  17. ActiveSheet.Copy after:=Sheets(Sheets.Count)
  18. With ActiveSheet
  19.      Intersect(.UsedRange, .UsedRange.Offset(1)).ClearContents
  20.      .[a2].Resize(x, 4) = brr
  21.      .Rows(1).Copy
  22.      .UsedRange.PasteSpecial Paste:=xlPasteFormats
  23.      .UsedRange.Borders.LineStyle = 1
  24. End With
  25. End Sub
复制代码
如图.png

实现D列分行.rar

25.09 KB, 下载次数: 13
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2015-9-11 14:43 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub XXX()
  2. Dim arr, brr, srr, a&, x&, s&
  3. arr = Range("a1").CurrentRegion
  4. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
  5. For a = 2 To UBound(arr)
  6.      If arr(a, 4) <> "" Then
  7.           srr = Split(arr(a, 4), ",")
  8.           For s = 0 To UBound(srr)
  9.                x = x + 1
  10.                brr(x, 1) = arr(a, 1)
  11.                brr(x, 2) = arr(a, 2)
  12.                brr(x, 3) = arr(a, 3)
  13.                brr(x, 4) = srr(s)
  14.           Next
  15.      End If
  16. Next
  17. ActiveSheet.Copy after:=Sheets(Sheets.Count)
  18. With ActiveSheet
  19.      Intersect(.UsedRange, .UsedRange.Offset(1)).ClearContents
  20.      .[a2].Resize(x, 4) = brr
  21. End With
  22. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2015-9-11 14:46 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub tt()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     ReDim brr(1 To 10 * UBound(arr), 1 To UBound(arr, 2))
  4.     For i = 1 To UBound(arr)
  5.         x = arr(i, 4)
  6.         xrr = Split(x, ",")
  7.         For k = 0 To UBound(xrr)
  8.             n = n + 1
  9.             For j = 1 To 3: brr(n, j) = arr(i, j): Next
  10.             brr(n, j) = xrr(k)
  11.         Next
  12.     Next
  13.     With Sheet2
  14.         .Cells.Clear
  15.         .[a1].Resize(n, 4) = brr
  16.         .[a1].Resize(n, 4).Borders.LineStyle = 1
  17.         .[c:c].WrapText = True
  18.     End With
  19. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2015-9-11 14:46 | 显示全部楼层
请看附件。

整理前.rar

29.39 KB, 下载次数: 11
回复

使用道具 举报

sj_dcy
 楼主| 发表于 2015-9-11 14:49 | 显示全部楼层
gufengaoyue 发表于 2015-9-11 14:43

能帮忙 再设置一下格式吗  就是不管多少数据都 所有的格式都一样   谢谢
回复

使用道具 举报

发表于 2015-9-11 14:55 | 显示全部楼层
sj_dcy 发表于 2015-9-11 14:49
能帮忙 再设置一下格式吗  就是不管多少数据都 所有的格式都一样   谢谢

你是说都加边框 ？
  1. Sub XXX()
  2. Dim arr, brr, srr, a&, x&, s&
  3. arr = Range("a1").CurrentRegion
  4. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
  5. For a = 2 To UBound(arr)
  6.      If arr(a, 4) <> "" Then
  7.           srr = Split(arr(a, 4), ",")
  8.           For s = 0 To UBound(srr)
  9.                x = x + 1
  10.                brr(x, 1) = arr(a, 1)
  11.                brr(x, 2) = arr(a, 2)
  12.                brr(x, 3) = arr(a, 3)
  13.                brr(x, 4) = srr(s)
  14.           Next
  15.      End If
  16. Next
  17. ActiveSheet.Copy after:=Sheets(Sheets.Count)
  18. With ActiveSheet
  19.      Intersect(.UsedRange, .UsedRange.Offset(1)).ClearContents
  20.      .[a2].Resize(x, 4) = brr
  21.      .Rows(1).Copy
  22.      .UsedRange.PasteSpecial Paste:=xlPasteFormats
  23.      Application.CutCopyMode = False
  24. End With
  25. End Sub
复制代码
回复

使用道具 举报

sj_dcy
 楼主| 发表于 2015-9-11 14:58 | 显示全部楼层
gufengaoyue 发表于 2015-9-11 14:55
你是说都加边框 ？

是的  刚才测试 要是数据多的话 下面的的一些就没有边框了
回复

使用道具 举报

grf1973
发表于 2015-9-11 14:59 | 显示全部楼层
另外那个分列的怎么删掉了，这可不是重复发帖。
  1. Sub tt()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     c = ActiveSheet.Columns.Count
  4.     ReDim brr(1 To UBound(arr), 1 To c)
  5.     For i = 1 To UBound(arr)
  6.         x = arr(i, 5)
  7.         n = n + 1
  8.         For j = 1 To 4: brr(n, j) = arr(i, j): Next
  9.         If x <> "" Then
  10.             xrr = Split(x, ",")
  11.             maxc = IIf(maxc > UBound(xrr) + 5, maxc, UBound(xrr) + 5)
  12.             For k = 0 To UBound(xrr): brr(n, k + 5) = xrr(k): Next
  13.         End If
  14.     Next
  15.     With Sheet2
  16.         .Cells.Clear
  17.         .[a1].Resize(n, maxc) = brr
  18.         .[a1].Resize(n, maxc).Borders.LineStyle = 1
  19.         .[c:c].WrapText = True
  20.     End With
  21. End Sub
复制代码

处理前.rar

30.29 KB, 下载次数: 7
回复

使用道具 举报

发表于 2015-9-11 15:15 | 显示全部楼层    本楼为最佳答案   
sj_dcy 发表于 2015-9-11 14:58
是的  刚才测试 要是数据多的话 下面的的一些就没有边框了

现在不是有了吗？
  1. Sub XXX()
  2. Dim arr, brr, srr, a&, x&, s&
  3. arr = Range("a1").CurrentRegion
  4. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
  5. For a = 2 To UBound(arr)
  6.      If arr(a, 4) <> "" Then
  7.           srr = Split(arr(a, 4), ",")
  8.           For s = 0 To UBound(srr)
  9.                x = x + 1
  10.                brr(x, 1) = arr(a, 1)
  11.                brr(x, 2) = arr(a, 2)
  12.                brr(x, 3) = arr(a, 3)
  13.                brr(x, 4) = srr(s)
  14.           Next
  15.      End If
  16. Next
  17. ActiveSheet.Copy after:=Sheets(Sheets.Count)
  18. With ActiveSheet
  19.      Intersect(.UsedRange, .UsedRange.Offset(1)).ClearContents
  20.      .[a2].Resize(x, 4) = brr
  21.      .Rows(1).Copy
  22.      .UsedRange.PasteSpecial Paste:=xlPasteFormats
  23.      .UsedRange.Borders.LineStyle = 1
  24. End With
  25. End Sub
复制代码
回复

使用道具 举报

sj_dcy
 楼主| 发表于 2015-9-11 15:21 | 显示全部楼层
grf1973 发表于 2015-9-11 14:59
另外那个分列的怎么删掉了，这可不是重复发帖。

恩  看明白了 谢谢你


回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-6-16 10:31 , Processed in 0.240379 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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