通讯录分组

江林

从原始的一列数据，变成右边的数组，有部分是两个号码，谢谢！

titi012

参与一下。。。

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, nrr(), i&, j&, c&, m&
   
3.     Dim d As Object, k, t, S$
   
4.     i = Cells(Rows.Count, 1).End(xlUp).Row
   
5.     arr = Range("a1:a" & i)
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     c = 0
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 1) Like "N:*" Then
   
10.             k = Replace(Replace(arr(i, 1), "N:", ""), ";", "")
    
11.             If Not d.Exists(k) Then Set d(k) = CreateObject("Scripting.Dictionary")
    
12.             S = Replace(arr(i + 1, 1), "FN:", "")
    
13.             m = 0
    
14.             For j = i + 2 To UBound(arr)
    
15.                 If arr(j, 1) Like "TEL*" Then
    
16.                     t = Right(arr(j, 1), Len(arr(j, 1)) - InStrRev(arr(j, 1), ":"))
    
17.                     d(k)(t) = S
    
18.                     m = m + 1
    
19.                     If m > c Then c = m
    
20.                 End If
    
21.                 If arr(j, 1) Like "END*" Then Exit For
    
22.             Next j
    
23.         End If
    
24.     Next i
    
25.     ReDim nrr(1 To d.Count, 1 To c + 2)
    
26.     i = 0
    
27.     For Each k In d.keys
    
28.         i = i + 1: j = 2
    
29.         For Each t In d(k).keys
    
30.             j = j + 1
    
31.             nrr(i, 1) = k
    
32.             nrr(i, 2) = d(k)(t)
    
33.             nrr(i, j) = t
    
34.         Next
    
35.     Next
    
36.     Range("c1").Resize(UBound(nrr), UBound(nrr, 2)) = nrr
    
37. End Sub

复制代码

杨建营

请楼主参考。

杨建营

1. Sub fenzu()
   
2. Dim i&, j&
   
3. Dim arr, brr
   
4. Dim reg
   
5. Application.ScreenUpdating = False
   
6. Set reg = CreateObject("vbscript.regexp")
   
7. arr = [a1].CurrentRegion
   
8. ReDim brr(1 To 1000, 1 To 4)
   
9. For i = 1 To UBound(arr)
   
10.     If i = 1 Then j = 1
    
11.     If i > 2 And Left(arr(i, 1), 2) = "N:" Then j = j + 1
    
12.     If Left(arr(i, 1), 2) = "N:" Then
    
13.         With reg
    
14.             .Global = True
    
15.             .Pattern = "(?:[;])([A-Za-z一-龟]+)"
    
16.             If .test(arr(i, 1)) Then
    
17.                 brr(j, 1) = .Execute(arr(i, 1))(0).submatches(0)
    
18.             End If
    
19.         End With
    
20.     End If
    
21.     If InStr(arr(i, 1), "FN") Then
    
22.         brr(j, 2) = Split(arr(i, 1), ":")(1)
    
23.     End If
    
24.     If Left(arr(i, 1), 3) = "TEL" Then
    
25.         If brr(j, 1) <> "" And brr(j, 3) = "" Then
    
26.             brr(j, 3) = Split(arr(i, 1), ":")(1) '.Execute(arr(i, 1))(0).submatches(0)
    
27.         Else
    
28.             brr(j, 4) = Split(arr(i, 1), ":")(1) '.Execute(arr(i, 1))(0).submatches(0)
    
29.         End If
    
30.     End If
    
31. Next
    
32. [h2].Resize(j, 4) = brr
    
33. Application.ScreenUpdating = True
    
34. End Sub
    

复制代码

条件判断有点乱。

grf1973

用到多个正则表达式，JS要方便一点。

grf1973

VBA版本的，也不复杂。

今铭昔