试图用字典解决，没想出来办法，求高手解答

zeuger

见附件。我刚开始学习VBA，读了蓝老师的字典集锦，感觉这个问题应该用字典解决，但是没有想出来。。。

lsdongjh

无关字典，只是一个字符串的拆分就行，split

zeuger

split 之后怎么弄，需要复制很多个学校名字。
有很多这样的行。

一把小刀闯天下

zeuger 发表于 2018-8-24 13:16
split 之后怎么弄，需要复制很多个学校名字。
有很多这样的行。

Option Explicit

Sub test()
  Dim arr, i, j, m, t
  arr = Range("a1").CurrentRegion.Offset(2).Value
  ReDim brr(1 To Rows.Count, 1 To 2) As String
  For i = 1 To UBound(arr, 1) - 2
    If InStr(arr(i, 2), Space(1)) Then
      t = Split(arr(i, 2), Space(1))
      For j = 0 To UBound(t)
        If Len(t(j)) Then
          m = m + 1: brr(m, 1) = arr(i, 1): brr(m, 2) = t(j)
        End If
      Next
    Else
      m = m + 1: brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2)
    End If
  Next
  With [d2] '输出位置自己修改
    .Resize(Rows.Count - 1, 2).ClearContents
    If m > 0 Then .Resize(m, 2) = brr
  End With
End Sub

hefuqing

1. Sub dd()
   
2. Dim brr(1 To 2, 1 To 100)
   
3. arr = Range("a3:b3")
   
4. For i = 1 To UBound(arr)
   
5. k = Split(arr(i, 2), " ")
   
6. For j = 0 To UBound(k) - 1
   
7. If k(j) <> "" Then
   
8. n = n + 1
   
9. brr(1, n) = arr(i, 1)
   
10. brr(2, n) = k(j)
    
11. End If
    
12. Next
    
13. Next
    
14. [a6].Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
15. End Sub

复制代码

zhenghui13

可以循环进行操作，请测试代码。如果数据真的非常多，可以先将结果存入内存数组，再一次输出。

1. Sub TZ_20180824()
   
2. Dim arr, brr
   
3. Dim i, j
   
4. Dim m
   
5. arr = Sheet1.UsedRange
   
6. With Sheet2
   
7. .Cells.ClearContents
   
8. For i = 2 To UBound(arr)
   
9.     brr = Split(arr(i, 2), " ")
   
10.     For j = 0 To UBound(brr)
    
11.        If Not brr(j) = "" Then
    
12.         m = m + 1
    
13.         .Cells(m, 1) = i - 1
    
14.         .Cells(m, 2) = arr(i, 1)
    
15.         .Cells(m, 3) = brr(j)
    
16.        End If
    
17.     Next j
    
18. Next i
    
19. End With
    
20. End Sub

复制代码

zhenghui13

代码审核中，附件仅供测试.

zhangzhang

详见附件，供参考。。。。。。。。。。。。