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

coreduo

大师能否注释一下，没看得懂，呵呵，新手

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             '把连接的字符串写入到数组中的第2列（相当于单元格所在行的第2列）
    
13.         str = ""                    '清空，下轮循环要用
    
14.     Next
    
15.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr '把整理的数组写回到工作表中
    
16.     'Sheet2.Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
17.     '上面写入到新位置，就需要考虑到数组的行和列大小，这样才能保证把数组内所有的元素全写回工作表中
    
18. End Sub
    
19. 
    
20. Sub 效果二()
    
21.     Dim arr
    
22.     arr = ActiveSheet.UsedRange
    
23.     Dim i&, str$, str2, j&, k&
    
24.     For i = 1 To UBound(arr)
    
25.         k = 1
    
26.         For j = 2 To UBound(arr, 2)
    
27.             If Len(arr(i, j)) > 0 Then  '判断是否是空值，如果有内容
    
28.                 k = k + 1               'k是指示要写入的列坐标，从第2列开始
    
29.                 If k <> j Then          '判断要写入的列标位置是否和当前循环到的列标相同，如果相同，则不需要进行操作
    
30.                     arr(i, k) = arr(i, j)   '把当前内容写入指定的列坐标中，并把当数组元素清空。相当于移位
    
31.                     arr(i, j) = ""          '移到新位置后，原来的老位置就要清空
    
32.                 End If
    
33.             End If
    
34.         Next
    
35.         k = 1                           '每行是从2列开始，找到合适的数据后，列坐标要加1，所以这里重置为1
    
36.     Next
    
37.     ActiveSheet.UsedRange.Offset(UBound(arr) + 1) = arr '写回工作表中。
    
38.     'Sheet2.Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
39.     '上面写入到新位置，就需要考虑到数组的行和列大小，这样才能保证把数组内所有的元素全写回工作表中
    
40. End Sub

复制代码

coreduo

hwc2ycy 发表于 2013-1-19 23:30

感谢感谢，又学了一课，3Q VM！