Excel精英培训网

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

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

[复制链接]
发表于 2015-9-11 14:26 | 显示全部楼层 |阅读模式
能不能通过VBA 再另一个表格里实现对原数据的D列进行分行?其他列根据情况进行复制
最佳答案
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 | 显示全部楼层
  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
复制代码
回复

使用道具 举报

发表于 2015-9-11 14:46 | 显示全部楼层
  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
复制代码
回复

使用道具 举报

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

整理前.rar

29.39 KB, 下载次数: 11

回复

使用道具 举报

 楼主| 发表于 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
复制代码
回复

使用道具 举报

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

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

使用道具 举报

发表于 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
复制代码
回复

使用道具 举报

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

恩  看明白了 谢谢你


回复

使用道具 举报

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

本版积分规则

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

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

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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