[已解决]请各位大师帮忙实现效果： 感谢hwc2ycy

coreduo

如图一，数据都是在一行的，如何在实现表二的两种效果，见图二，即，跳过空的单元格，直接从空格之后的第一个数据开始读，遇有空格均跳过，直至最后一个数据。
3Q！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-19 22:51

1. Sub 效果一()
   
2.     Dim arr
   
3.     arr = ActiveSheet.UsedRange
   
4.     Dim i&, str$, str2, j&
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2)
   
7.             str = str & arr(i, j)
   
8.             arr(i, j) = ""
   
9.         Next
   
10.         arr(i, 2) = str
    
11.         str = ""
    
12.     Next
    
13.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr
    
14.    
    
15. End Sub
    
16. 
    
17. Sub 效果二()
    
18.     Dim arr
    
19.     arr = ActiveSheet.UsedRange
    
20.     Dim i&, str$, str2, j&, k&
    
21.     For i = 1 To UBound(arr)
    
22.         k = 1
    
23.         For j = 2 To UBound(arr, 2)
    
24.             If Len(arr(i, j)) > 0 Then
    
25.                 k = k + 1
    
26.                 If k <> j Then
    
27.                     arr(i, k) = arr(i, j)
    
28.                     arr(i, j) = ""
    
29.                 End If
    
30.             End If
    
31.         Next
    
32.         k = 1
    
33.     Next
    
34.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr
    
35. End Sub

复制代码

隔行输出整理后的数据

跳转到最佳答案楼层

hwc2ycy

1. Option Explicit
   
2. 
   
3. Sub 效果一()
   
4.     Dim arr
   
5.     arr = ActiveSheet.UsedRange
   
6.     Dim i&, str$, str2, j&
   
7.     For i = 1 To UBound(arr)
   
8.         For j = 2 To UBound(arr, 2)
   
9.             str = str & arr(i, j)
   
10.             arr(i, j) = ""
    
11.         Next
    
12.         arr(i, 2) = str
    
13.         str = ""
    
14.     Next
    
15.     Stop
    
16. End Sub
    
17. 
    
18. Sub 效果二()
    
19.     Dim arr
    
20.     arr = ActiveSheet.UsedRange
    
21.     Dim i&, str$, str2, j&, k&
    
22.     For i = 1 To UBound(arr)
    
23.         k = 1
    
24.         For j = 2 To UBound(arr, 2)
    
25.             If Len(arr(i, j)) > 0 Then
    
26.                 k = k + 1
    
27.                 If k <> j Then
    
28.                     arr(i, k) = arr(i, j)
    
29.                     arr(i, j) = ""
    
30.                 End If
    
31.             End If
    
32.         Next
    
33.         k = 1
    
34.     Next
    
35.     Stop
    
36. End Sub
    

复制代码

代码暂停后看本地窗口，如果写回单元格，再加一句写回的代码就行了。

coreduo

大师，在 stop那里报错啊，  运行代码时，这个地方变黄。。。。

hwc2ycy

1. Sub 效果一()
   
2.     Dim arr
   
3.     arr = ActiveSheet.UsedRange
   
4.     Dim i&, str$, str2, j&
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2)
   
7.             str = str & arr(i, j)
   
8.             arr(i, j) = ""
   
9.         Next
   
10.         arr(i, 2) = str
    
11.         str = ""
    
12.     Next
    
13.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr
    
14.    
    
15. End Sub
    
16. 
    
17. Sub 效果二()
    
18.     Dim arr
    
19.     arr = ActiveSheet.UsedRange
    
20.     Dim i&, str$, str2, j&, k&
    
21.     For i = 1 To UBound(arr)
    
22.         k = 1
    
23.         For j = 2 To UBound(arr, 2)
    
24.             If Len(arr(i, j)) > 0 Then
    
25.                 k = k + 1
    
26.                 If k <> j Then
    
27.                     arr(i, k) = arr(i, j)
    
28.                     arr(i, j) = ""
    
29.                 End If
    
30.             End If
    
31.         Next
    
32.         k = 1
    
33.     Next
    
34.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr
    
35. End Sub

复制代码

隔行输出整理后的数据

coreduo

我还是上传附件算了

hwc2ycy

那是暂停，不是报错。
你直接用新代码吧。

coreduo

hwc2ycy 发表于 2013-1-19 22:51
隔行输出整理后的数据

写入SHEET2指定的单元格，怎么加上去？

hwc2ycy

1. sheet2.range("a1").resize(ubound(arr),uboun(arr,2))=arr

复制代码

coreduo

hwc2ycy 发表于 2013-1-19 22:57

我用它替换了这一句ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr  结果说  子过程或函数未定义

hwc2ycy

1. sheet2.range("a1").resize(ubound(arr),ubound(arr,2))=arr

复制代码

不好意思，漏了个字。