[已解决]求助：带有拆分的插入行v1. ...

水木

求助：带有拆分的插入行v1.zip (12.9 KB, 下载次数: 13)

2014-11-21 23:15 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-11-22 06:16

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 5)
   
3. Dim i&, s&, j%, k%, k2%, gjc$$
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. gjc = "词林" '关键词
   
6. For i = 2 To UBound(arr)
   
7.     If arr(i, 5) = gjc Then
   
8.         x = Split(arr(i, 6))
   
9.         For j = 0 To UBound(x)
   
10.             If x(j) <> "" Then
    
11.                 s = s + 1
    
12.                 If j = 0 Then
    
13.                     brr(s, 1) = arr(i, 1)
    
14.                     brr(s, 2) = arr(i, 2)
    
15.                     brr(s, 3) = arr(i, 5)
    
16.                 End If
    
17.                 brr(s, 5) = x(j)
    
18.             End If
    
19.         Next
    
20.         For k = 7 To UBound(arr, 2)
    
21.             If arr(i, k) <> "" Then s = s + 1: brr(s, 5) = arr(i, k)
    
22.         Next
    
23.     Else
    
24.         s = s + 1
    
25.         brr(s, 1) = arr(i, 1)
    
26.         brr(s, 2) = arr(i, 2)
    
27.         brr(s, 3) = arr(i, 5)
    
28.         brr(s, 5) = arr(i, 6)
    
29.         For k2 = 7 To UBound(arr, 2)
    
30.             If arr(i, k2) <> "" Then s = s + 1: brr(s, 5) = arr(i, k2)
    
31.         Next
    
32.     End If
    
33. Next
    
34. [a1:e1].Value = "标题"
    
35. Range("a2").Resize(s, 5) = brr
    
36. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 5)
   
3. Dim i&, s&, j%, k%, k2%, gjc$$
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. gjc = "词林" '关键词
   
6. For i = 2 To UBound(arr)
   
7.     If arr(i, 5) = gjc Then
   
8.         x = Split(arr(i, 6))
   
9.         For j = 0 To UBound(x)
   
10.             If x(j) <> "" Then
    
11.                 s = s + 1
    
12.                 If j = 0 Then
    
13.                     brr(s, 1) = arr(i, 1)
    
14.                     brr(s, 2) = arr(i, 2)
    
15.                     brr(s, 3) = arr(i, 5)
    
16.                 End If
    
17.                 brr(s, 5) = x(j)
    
18.             End If
    
19.         Next
    
20.         For k = 7 To UBound(arr, 2)
    
21.             If arr(i, k) <> "" Then s = s + 1: brr(s, 5) = arr(i, k)
    
22.         Next
    
23.     Else
    
24.         s = s + 1
    
25.         brr(s, 1) = arr(i, 1)
    
26.         brr(s, 2) = arr(i, 2)
    
27.         brr(s, 3) = arr(i, 5)
    
28.         brr(s, 5) = arr(i, 6)
    
29.         For k2 = 7 To UBound(arr, 2)
    
30.             If arr(i, k2) <> "" Then s = s + 1: brr(s, 5) = arr(i, k2)
    
31.         Next
    
32.     End If
    
33. Next
    
34. [a1:e1].Value = "标题"
    
35. Range("a2").Resize(s, 5) = brr
    
36. End Sub

复制代码

dsmch

………………