|
发表于 2013-3-25 18:49
|
显示全部楼层
本楼为最佳答案
列宽,行高调整了,这样看着舒服点。- Sub 合并()
- Dim arr, i&
- arr = Range("a1").CurrentRegion
- Dim result(), l&, lPos&
- Dim arrSize()
- ReDim result(1 To UBound(arr), 1 To 3)
- ReDim arrSize(1 To UBound(arr), 1 To 1)
- Dim dic As Object, strTemp$
- Dim lNewline&
- lNewline = 1
- Set dic = CreateObject("scripting.dictionary")
- For i = LBound(arr) + 1 To UBound(arr)
- strTemp = arr(i, 1) & "|" & arr(i, 2)
- If Not dic.exists(strTemp) Then
- l = l + 1
- lPos = l
- dic(strTemp) = lPos
- result(lPos, 1) = arr(i, 1)
- result(lPos, 2) = arr(i, 2)
- 'arrSize(lPos, 1) = 1
- Else
- lPos = dic(strTemp)
- End If
- If arrSize(lPos, 1) = 5 Then result(lPos, 3) = result(lPos, 3) & vbNewLine: arrSize(lPos, 1) = 0
- result(lPos, 3) = result(lPos, 3) & arr(i, 3) & "、"
- arrSize(lPos, 1) = arrSize(lPos, 1) + 1
- Next
- For i = 1 To l
- result(i, 3) = Left(result(i, 3), Len(result(i, 3)) - 2)
- Next
- Application.ScreenUpdating = False
- If l > 0 Then
- Range("h1").Resize(, 3) = Array("市/县", "区", "镇")
- Range("h2").Resize(l, UBound(result, 2)) = result
- With Range("j:j")
- .WrapText = True
- .ColumnWidth = "39"
- .EntireColumn.AutoFit
- End With
- Range("h1").CurrentRegion.EntireRow.AutoFit
- End If
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|