[已解决]如何用VBA来提取A列的部门名称至单元格？

蓝火雨

如何用VBA来提取A列的部门名称至单元格？具体要求在附件中，请大家帮忙，谢谢！！

最佳答案

月排行榜 / 总排行榜

zjyxp

2014-1-22 20:51

1. Sub t1()
   
2.     Dim i As Integer, j As Integer
   
3.     Dim Rowcount As Integer
   
4.     Dim se5 As String, sf5 As String
   
5.     Dim se6 As String, sf6 As String
   
6.     Dim k As Integer, l As Integer
   
7.     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
   
8.         Rowcount = Cells(i, 1).MergeArea.Count
   
9.         If Rowcount = 1 Then
   
10.             If Cells(i, 2) Then
    
11.                 se5 = se5 & Cells(i, 1).Value
    
12.             Else
    
13.                 se6 = se6 & Cells(i, 1).Value
    
14.             End If
    
15.         Else
    
16.             For j = 1 To Rowcount
    
17.                 If Cells(i + j - 1, 2) > 0.5 Then Exit For
    
18.                 If Cells(i + j - 1, 2) < 0.5 Then
    
19.                     k = k + 1
    
20.                 ElseIf Cells(i + j - 1, 2) = 0 Then
    
21.                     l = l + 1
    
22.                 End If
    
23.             Next j
    
24.             If k = Rowcount Then
    
25.                 sf6 = sf6 & Cells(i, 1).Value
    
26.             ElseIf l = Rowcount Then
    
27.                 se6 = se6 & Cells(i, 1).Value
    
28.             End If
    
29.             i = i + Rowcount - 1
    
30.             k = 0
    
31.             l = 0
    
32.         End If
    
33.     Next i
    
34.     [e5] = se5
    
35.     [f5] = sf5
    
36.     [e6] = se6
    
37.     [f6] = sf6
    
38. End Sub
    

复制代码

没看到结果，不知这个结果是否满足要求

跳转到最佳答案楼层

zjyxp

1. Sub t1()
   
2.     Dim i As Integer, j As Integer
   
3.     Dim Rowcount As Integer
   
4.     Dim se5 As String, sf5 As String
   
5.     Dim se6 As String, sf6 As String
   
6.     Dim k As Integer, l As Integer
   
7.     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
   
8.         Rowcount = Cells(i, 1).MergeArea.Count
   
9.         If Rowcount = 1 Then
   
10.             If Cells(i, 2) Then
    
11.                 se5 = se5 & Cells(i, 1).Value
    
12.             Else
    
13.                 se6 = se6 & Cells(i, 1).Value
    
14.             End If
    
15.         Else
    
16.             For j = 1 To Rowcount
    
17.                 If Cells(i + j - 1, 2) > 0.5 Then Exit For
    
18.                 If Cells(i + j - 1, 2) < 0.5 Then
    
19.                     k = k + 1
    
20.                 ElseIf Cells(i + j - 1, 2) = 0 Then
    
21.                     l = l + 1
    
22.                 End If
    
23.             Next j
    
24.             If k = Rowcount Then
    
25.                 sf6 = sf6 & Cells(i, 1).Value
    
26.             ElseIf l = Rowcount Then
    
27.                 se6 = se6 & Cells(i, 1).Value
    
28.             End If
    
29.             i = i + Rowcount - 1
    
30.             k = 0
    
31.             l = 0
    
32.         End If
    
33.     Next i
    
34.     [e5] = se5
    
35.     [f5] = sf5
    
36.     [e6] = se6
    
37.     [f6] = sf6
    
38. End Sub
    

复制代码

没看到结果，不知这个结果是否满足要求

蓝火雨

zjyxp 发表于 2014-1-22 20:51
没看到结果，不知这个结果是否满足要求

结果不重要，代码的思路就是我想要的，感谢帮助呀！！