Excel精英培训网

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

[已解决]求助:以空格拆分的插入整行 ...

[复制链接]
发表于 2014-11-22 07:49 | 显示全部楼层 |阅读模式
求助:以空格拆分的插入整行22.zip (13.37 KB, 下载次数: 6)
发表于 2014-11-22 09:05 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr(1 To 60000, 1 To 5)
  3. Dim i&, s&, j%, k%, k2%
  4. arr = Sheet1.Range("a1").CurrentRegion
  5. For i = 2 To UBound(arr)
  6.         x = Split(arr(i, 6))
  7.         For j = 0 To UBound(x)
  8.             If x(j) <> "" Then
  9.                 s = s + 1
  10.                 If j = 0 Then
  11.                     brr(s, 1) = arr(i, 1)
  12.                     brr(s, 2) = arr(i, 2)
  13.                     brr(s, 3) = arr(i, 5)
  14.                 End If
  15.                 brr(s, 5) = x(j)
  16.             End If
  17.         Next
  18.         For k = 7 To UBound(arr, 2)
  19.             If arr(i, k) <> "" Then
  20.                 y = Split(arr(i, k))
  21.                 For l = 0 To UBound(y)
  22.                     If y(l) <> "" Then
  23.                         s = s + 1
  24.                         brr(s, 5) = y(l)
  25.                     End If
  26.                 Next
  27.             End If
  28.         Next
  29. Next
  30. [a1:e1].Value = "标题"
  31. Range("a2").Resize(s, 5) = brr
  32. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
水木 + 1 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2014-11-22 09:07 | 显示全部楼层
………………

求助:以空格拆分的插入整行22.zip

11.51 KB, 下载次数: 10

评分

参与人数 1 +1 收起 理由
水木 + 1 感谢!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2014-11-22 10:05 | 显示全部楼层
dsmch 发表于 2014-11-22 09:07
………………

原附件中,由于我模拟不到位,给您添麻烦了。 再求助:以空格拆分的插入整行22.zip (11.66 KB, 下载次数: 6)
回复

使用道具 举报

发表于 2014-11-22 10:23 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim arr, brr(1 To 60000, 1 To 6)
  3. Dim i&, s&, j%, k%, j2%, l%
  4. arr = Sheet1.Range("a1").CurrentRegion
  5. For i = 2 To UBound(arr)
  6.         x = Split(arr(i, 6))
  7.         For j = 0 To UBound(x)
  8.             If x(j) <> "" Then
  9.                 s = s + 1
  10.                 If j = 0 Then
  11.                     For j2 = 1 To 5
  12.                         brr(s, j2) = arr(i, j2)
  13.                     Next
  14.                 End If
  15.                 brr(s, 6) = x(j)
  16.             End If
  17.         Next
  18.         For k = 7 To UBound(arr, 2)
  19.             If arr(i, k) <> "" Then
  20.                 y = Split(arr(i, k))
  21.                 For l = 0 To UBound(y)
  22.                     If y(l) <> "" Then
  23.                         s = s + 1
  24.                         brr(s, 6) = y(l)
  25.                     End If
  26.                 Next
  27.             End If
  28.         Next
  29. Next
  30. [a1:f1].Value = "标题"
  31. Range("a2").Resize(s, 6) = brr
  32. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
水木 + 1 很给力! 非常感谢!

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 03:46 , Processed in 0.517051 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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