Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2003|回复: 5

[已解决]VBA变换格式(江湖救急)

[复制链接]
发表于 2013-3-25 17:47 | 显示全部楼层 |阅读模式
我有个行政区域表,要调一下格式,请路过的高人赐一个VBA代码,谢谢 QQ截图20130325174720.jpg
最佳答案
2013-3-25 18:49
列宽,行高调整了,这样看着舒服点。
  1. Sub 合并()
  2.     Dim arr, i&
  3.     arr = Range("a1").CurrentRegion
  4.     Dim result(), l&, lPos&
  5.     Dim arrSize()

  6.     ReDim result(1 To UBound(arr), 1 To 3)
  7.     ReDim arrSize(1 To UBound(arr), 1 To 1)
  8.     Dim dic As Object, strTemp$
  9.     Dim lNewline&
  10.     lNewline = 1
  11.     Set dic = CreateObject("scripting.dictionary")

  12.     For i = LBound(arr) + 1 To UBound(arr)
  13.         strTemp = arr(i, 1) & "|" & arr(i, 2)
  14.         If Not dic.exists(strTemp) Then
  15.             l = l + 1
  16.             lPos = l
  17.             dic(strTemp) = lPos
  18.             result(lPos, 1) = arr(i, 1)
  19.             result(lPos, 2) = arr(i, 2)
  20.             'arrSize(lPos, 1) = 1
  21.         Else
  22.             lPos = dic(strTemp)
  23.         End If
  24.         If arrSize(lPos, 1) = 5 Then result(lPos, 3) = result(lPos, 3) & vbNewLine: arrSize(lPos, 1) = 0
  25.         result(lPos, 3) = result(lPos, 3) & arr(i, 3) & "、"
  26.         arrSize(lPos, 1) = arrSize(lPos, 1) + 1

  27.     Next
  28.     For i = 1 To l
  29.         result(i, 3) = Left(result(i, 3), Len(result(i, 3)) - 2)
  30.     Next
  31.     Application.ScreenUpdating = False
  32.     If l > 0 Then
  33.         Range("h1").Resize(, 3) = Array("市/县", "区", "镇")
  34.         Range("h2").Resize(l, UBound(result, 2)) = result
  35.         With Range("j:j")
  36.             .WrapText = True
  37.             .ColumnWidth = "39"
  38.             .EntireColumn.AutoFit
  39.         End With
  40.         Range("h1").CurrentRegion.EntireRow.AutoFit
  41.     End If
  42.     Application.ScreenUpdating = True
  43. End Sub
复制代码
QQ截图20130325174720.jpg

行政区域表.rar

4.4 KB, 下载次数: 12

发表于 2013-3-25 17:52 | 显示全部楼层
回复

使用道具 举报

发表于 2013-3-25 18:10 | 显示全部楼层
本帖最后由 hwc2ycy 于 2013-3-25 18:24 编辑

由Sheet1生成Sheet4效果
  1. Sub 合并()
  2.     Dim arr, i&
  3.     arr = Range("a1").CurrentRegion
  4.     Dim result(), l&, lPos&
  5.     ReDim result(1 To UBound(arr), 1 To 3)
  6.     Dim dic As Object, strTemp$
  7.     Dim lNewline&
  8.     lNewline = 1
  9.     Set dic = CreateObject("scripting.dictionary")
  10.    
  11.     For i = LBound(arr) + 1 To UBound(arr)
  12.         strTemp = arr(i, 1) & "|" & arr(i, 2)
  13.         If Not dic.exists(strTemp) Then
  14.             l = l + 1
  15.             lPos = l
  16.             dic(strTemp) = l
  17.             result(lPos, 1) = arr(i, 1)
  18.             result(lPos, 2) = arr(i, 2)
  19.         Else
  20.             lPos = dic(strTemp)
  21.         End If
  22.         result(lPos, 3) = result(lPos, 3) & arr(i, 3) & "、"
  23.             
  24.         
  25.     Next
  26.     For i = 1 To l
  27.         result(i, 3) = Left(result(i, 3), Len(result(i, 3)) - 1)
  28.     Next
  29.     Range("h1").Resize(, 3) = Array("市/县", "区", "镇")
  30.     Range("h2").Resize(l, UBound(result, 2)) = result
  31. End Sub
复制代码
回复

使用道具 举报

发表于 2013-3-25 18:21 | 显示全部楼层
由shee4生成sheet1效果。
  1. Sub 拆分()
  2.     Dim arr
  3.     Dim arrTemp
  4.     Dim i&, lArrSize&, lPos&, k As Byte
  5.     Dim result(1 To 3000, 1 To 3)
  6.    
  7.     arr = Range("a1").CurrentRegion
  8.     lPos = 0
  9.     For i = LBound(arr) + 1 To UBound(arr)
  10.         arrTemp = Split(arr(i, 3), "、")
  11.         lArrSize = UBound(arrTemp)
  12.         For k = 0 To UBound(arrTemp)
  13.             lPos = lPos + 1
  14.             result(lPos, 1) = arr(i, 1)
  15.             result(lPos, 2) = arr(i, 2)
  16.             result(lPos, 3) = arrTemp(k)
  17.         Next
  18.     Next
  19.     Stop
  20.     If lPos > 0 Then
  21.     Range("h1").Resize(, 3) = Array("市/县", "区", "镇")
  22.     Range("h2").Resize(lPos, UBound(result, 2)) = result
  23.     End If
  24. End Sub
复制代码
回复

使用道具 举报

发表于 2013-3-25 18:34 | 显示全部楼层
第一个效果没有做换行处理,效果不那么美观。
回复

使用道具 举报

发表于 2013-3-25 18:49 | 显示全部楼层    本楼为最佳答案   
列宽,行高调整了,这样看着舒服点。
  1. Sub 合并()
  2.     Dim arr, i&
  3.     arr = Range("a1").CurrentRegion
  4.     Dim result(), l&, lPos&
  5.     Dim arrSize()

  6.     ReDim result(1 To UBound(arr), 1 To 3)
  7.     ReDim arrSize(1 To UBound(arr), 1 To 1)
  8.     Dim dic As Object, strTemp$
  9.     Dim lNewline&
  10.     lNewline = 1
  11.     Set dic = CreateObject("scripting.dictionary")

  12.     For i = LBound(arr) + 1 To UBound(arr)
  13.         strTemp = arr(i, 1) & "|" & arr(i, 2)
  14.         If Not dic.exists(strTemp) Then
  15.             l = l + 1
  16.             lPos = l
  17.             dic(strTemp) = lPos
  18.             result(lPos, 1) = arr(i, 1)
  19.             result(lPos, 2) = arr(i, 2)
  20.             'arrSize(lPos, 1) = 1
  21.         Else
  22.             lPos = dic(strTemp)
  23.         End If
  24.         If arrSize(lPos, 1) = 5 Then result(lPos, 3) = result(lPos, 3) & vbNewLine: arrSize(lPos, 1) = 0
  25.         result(lPos, 3) = result(lPos, 3) & arr(i, 3) & "、"
  26.         arrSize(lPos, 1) = arrSize(lPos, 1) + 1

  27.     Next
  28.     For i = 1 To l
  29.         result(i, 3) = Left(result(i, 3), Len(result(i, 3)) - 2)
  30.     Next
  31.     Application.ScreenUpdating = False
  32.     If l > 0 Then
  33.         Range("h1").Resize(, 3) = Array("市/县", "区", "镇")
  34.         Range("h2").Resize(l, UBound(result, 2)) = result
  35.         With Range("j:j")
  36.             .WrapText = True
  37.             .ColumnWidth = "39"
  38.             .EntireColumn.AutoFit
  39.         End With
  40.         Range("h1").CurrentRegion.EntireRow.AutoFit
  41.     End If
  42.     Application.ScreenUpdating = True
  43. End Sub
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 19:30 , Processed in 0.593856 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表