[已解决]以E列的“生字”和F列的“ ...

水木

以E列的“生字”和F列的“基本解释”为关键词，在G列，将“基本解释”的单元格中的内.rar (18.22 KB, 下载次数: 6)

2016-10-3 09:54 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

雨吧

2016-10-3 12:21

1. Sub YuBa()
   
2.     Dim rng As Range
   
3.     e = [g65536].End(3).Row
   
4.     For i = 1 To e
   
5.         n = 0
   
6.         If Cells(i, "f") = "基本解释" Then
   
7.             n = n + i + 1
   
8.             Do While Cells(n, "f") = "" And n <= e
   
9.                 Cells(i, "g") = Cells(i, "g") & "*" & Cells(n, "g")
   
10.                 If rng Is Nothing Then
    
11.                     Set rng = Rows(n)
    
12.                 Else
    
13.                     Set rng = Union(rng, Rows(n))
    
14.                 End If
    
15.                 n = n + 1
    
16.             Loop
    
17.             i = n - 1
    
18.         End If
    
19.     Next
    
20.     rng.Delete
    
21. End Sub

复制代码

以E列的“生字”和F列的“基本解释”为关键词，在G列，将“基本解释”的单元格中的内.rar (24.9 KB, 下载次数: 4)

2016-10-3 12:21 上传

点击文件名下载附件

跳转到最佳答案楼层

today0427

请查看

1. Sub today()
   
2.     Dim arr, brr(), i&, k&, ro&
   
3.     arr = Sheets("Sheet1").Range("e1:g" & Sheets("Sheet1").[g65536].End(3).Row)
   
4.     For i = 1 To UBound(arr)
   
5.         If arr(i, 1) <> "" And arr(i, 2) = "基本解释" Then
   
6.             For ro = i + 1 To UBound(arr)
   
7.                 If arr(ro, 1) = "" And arr(ro, 3) <> "" Then
   
8.                     arr(i, 3) = arr(i, 3) & " * " & arr(ro, 3)
   
9.                     arr(ro, 3) = ""
   
10.                 Else: Exit For
    
11.                 End If
    
12.             Next
    
13.         End If
    
14.     Next
    
15.    
    
16.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
17.     For i = 1 To UBound(arr)
    
18.         If arr(i, 2) <> "" Or arr(i, 3) <> "" Then
    
19.             k = k + 1
    
20.             For j = 1 To UBound(arr, 2)
    
21.                 brr(k, j) = arr(i, j)
    
22.             Next
    
23.         End If
    
24.     Next
    
25.    
    
26.     Sheets("Sheet1").Columns("i:k").Clear
    
27.     Sheets("Sheet1").[i1].Resize(k, j - 1) = brr
    
28. End Sub
    

复制代码

雨吧

1. Sub YuBa()
   
2.     Dim rng As Range
   
3.     e = [g65536].End(3).Row
   
4.     For i = 1 To e
   
5.         n = 0
   
6.         If Cells(i, "f") = "基本解释" Then
   
7.             n = n + i + 1
   
8.             Do While Cells(n, "f") = "" And n <= e
   
9.                 Cells(i, "g") = Cells(i, "g") & "*" & Cells(n, "g")
   
10.                 If rng Is Nothing Then
    
11.                     Set rng = Rows(n)
    
12.                 Else
    
13.                     Set rng = Union(rng, Rows(n))
    
14.                 End If
    
15.                 n = n + 1
    
16.             Loop
    
17.             i = n - 1
    
18.         End If
    
19.     Next
    
20.     rng.Delete
    
21. End Sub

复制代码

以E列的“生字”和F列的“基本解释”为关键词，在G列，将“基本解释”的单元格中的内.rar (24.9 KB, 下载次数: 4)

2016-10-3 12:21 上传

点击文件名下载附件

su45

昨天做好了的数组方式的：

1. Sub suaa()
   
2. rw = Cells(Rows.Count, 7).End(3).Row
   
3. Rng = Range("E2:G" & rw)
   
4. ReDim arr(1 To UBound(Rng), 1 To 3)
   
5. a = 1
   
6. Do While a < UBound(Rng) + 1
   
7.     x = x + 1
   
8.     If Rng(a, 2) = "基本解释" Then
   
9.         arr(x, 1) = Rng(a, 1): arr(x, 2) = Rng(a, 2)
   
10.         arr(x, 2) = Rng(a, 2): p = Rng(a, 3)
    
11.         b = a + 1
    
12.         If b < UBound(Rng) + 1 Then
    
13.             Do While Rng(b, 2) = ""
    
14.                 If Rng(b, 2) = "" Then
    
15.                     p = p & "*" & Rng(b, 3)
    
16.                 End If
    
17.                 b = b + 1
    
18.             Loop
    
19.         End If
    
20.             arr(x, 3) = p
    
21.             a = b
    
22.     Else
    
23.         arr(x, 1) = Rng(a, 1): arr(x, 2) = Rng(a, 2): arr(x, 3) = Rng(a, 3)
    
24.         a = a + 1
    
25.     End If
    
26. Loop
    
27. Range("A1").Resize(x, 3) = arr '写入到A：C列
    
28. End Sub

复制代码