行列格式转换问题

wmq142703

在对省市区转换成对应格式，类似多行转一列，大神帮忙看看。附件

wang-way

1. Sub try()
   
2.     Dim d, endrow, i
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     endrow = Range("A65536").End(3).Row
   
5.     For i = 3 To endrow
   
6.         Key = Cells(i, 1).Value & "/" & Cells(i, 2).Value
   
7.         If Not d.Exists(Key) Then
   
8.             d(Key) = Cells(i, 3).Value
   
9.         Else
   
10.             d(Key) = d(Key) & ";" & Cells(i, 3).Value
    
11.         End If
    
12.     Next i
    
13.     j = 8
    
14.     For Each k In d.keys
    
15.         j = j + 1
    
16.         Cells(3, j).Value = Split(k, "/")(1)
    
17.         Cells(4, j).Resize(UBound(Split(d(k), ";")) + 1, 1).Value = Split(d(k), ";")
    
18.     Next k
    
19. End Sub
    

复制代码

wmq142703

wang-way 发表于 2018-10-18 20:19

谢谢。不好意思，苏州市上边还有个江苏省。并排列的。

ww87725244

1. Option Explicit
   
2. Sub aa()
   
3. Dim ar, i&, d As Object, s$, ar1(), k&, m&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     ar = .Range(.Cells(3, 1), .Cells(.Rows.Count, 3).End(3))
   
7.     For i = 1 To UBound(ar)
   
8.         If Not d.exists(ar(i, 2)) Then
   
9.             k = k + 1
   
10.             m = 0
    
11.             ReDim Preserve ar1(1 To UBound(ar), 1 To k)
    
12.             ar1(1, k) = ar(i, 1)
    
13.             ar1(2, k) = ar(i, 2)
    
14.             ar1(3, k) = ar(i, 3)
    
15.             d(ar(i, 2)) = ""
    
16.         Else
    
17.             s = ar(i, 2) & "" & ar(i, 3)
    
18.             If Not d.exists(s) Then
    
19.                 m = m + 1
    
20.                 ar1(m + 3, k) = Split(s, "")(1)
    
21.             End If
    
22.         End If   
    
23.     Next
    
24.     .[i3].Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    
25. End With
    
26. Set d = Nothing
    
27. End Sub
    

复制代码