设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 数据展开，hurry
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2446|回复: 6

[已解决]数据展开，hurry

[复制链接]
发表于 2014-11-3 15:47 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 billyzhang0609 于 2014-11-3 19:45 编辑

如题如附件：

      做出如图的效果，请问如何实现？
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2014-11-3 17:10
  1. Sub demo()
  2.     Dim arr, arr3(1 To 256, 1 To 12)
  3.     Dim i&, j&, k&, lRow&
  4.     Dim sht As Worksheet
  5.     Dim strPrefix$, lSn&

  7.     '源数据
  8.     arr = Range("a1").CurrentRegion
  9.     Application.ScreenUpdating = False
  10.     Set sht = Worksheets.Add(after:=ActiveSheet)
  11.     lRow = 2
  12.     '标题行
  13.     Range("a1").Resize(, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, 1)
  14.     '每一行原始记录
  15.     For i = 2 To UBound(arr)

  17.         strPrefix = Left(arr(i, 1), 2)        '序号前缀
  18.         lSn = Mid(arr(i, 1), 3) '起始序号
  19.         For j = 0 To arr(i, 2) - 1  '重复次数
  20.             For k = 3 To UBound(arr, 2)
  21.                 arr3(j + 1, 1) = strPrefix & lSn + j '3-12列数据写入新数组中
  22.                 arr3(j + 1, k) = arr(i, k) '新序号
  23.             Next
  24.         Next
  25.         arr3(1, 2) = arr(i, 2) '第一行第2列数量
  26.         If j Then
  27.             '写回到工作表中并设置格式
  28.             With Cells(lRow, 1).Resize(j, UBound(arr3, 2))
  29.                 .Value = arr3
  30.                 .Borders(xlDiagonalDown).LineStyle = xlNone
  31.                 .Borders(xlDiagonalUp).LineStyle = xlNone
  32.                 With .Borders
  33.                     .LineStyle = xlContinuous
  34.                 End With
  35.                 .Borders(xlInsideVertical).LineStyle = xlNone
  36.                 .Borders(xlInsideHorizontal).LineStyle = xlNone
  37.             End With
  38.             Erase arr3 '数组清空
  39.             lRow = lRow + j '行号
  40.         End If
  41.     Next
  42.     Application.ScreenUpdating = True
  43.     MsgBox "筛选后的结果在 工作表 " & ActiveSheet.Name & " 中"
  44.     ActiveSheet.Previous.Select
  45. End Sub
复制代码

几万行数据展开

几万行数据展开

数据展开.zip

9.73 KB, 下载次数: 15
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
qh8600
发表于 2014-11-3 16:21 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
这个展开是啥意思
回复

使用道具 举报

hwc2ycy
发表于 2014-11-3 17:03 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub demo()
  2.     Dim arr, arr2
  3.     Dim lRow&
  4.     arr = Range("a1").CurrentRegion
  5.     Dim i&, j&, k&
  6.     Dim arr3(1 To 256, 1 To 12)
  7.     Application.ScreenUpdating = False

  9.     Dim sht As Worksheet
  10.     Set sht = Worksheets.Add(after:=ActiveSheet)
  11.     lRow = 2
  12.     Range("a1").Resize(, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, 1)
  13.     For i = 2 To UBound(arr)
  14.         Dim strPrefix$
  15.         Dim lsn&
  16.         strPrefix = Left(arr(i, 1), 2)
  17.         lsn = Mid(arr(i, 1), 3)
  18.         For j = 0 To arr(i, 2) - 1

  20.             For k = 3 To UBound(arr, 2)
  21.                 arr3(j + 1, 1) = strPrefix & lsn + j
  22.                 arr3(j + 1, k) = arr(i, k)
  23.             Next
  24.         Next
  25.         arr3(1, 2) = arr(i, 2)
  26.         If j Then
  27.             With Cells(lRow, 1).Resize(j, UBound(arr3, 2))
  28.                 .Value = arr3
  29.                 .Borders(xlDiagonalDown).LineStyle = xlNone
  30.                 .Borders(xlDiagonalUp).LineStyle = xlNone
  31.                 With .Borders
  32.                     .LineStyle = xlContinuous
  33.                 End With

  35.                 .Borders(xlInsideVertical).LineStyle = xlNone
  36.                 .Borders(xlInsideHorizontal).LineStyle = xlNone
  37.             End With
  38.             Erase arr3
  39.             lRow = lRow + j
  40.         End If
  41.     Next
  42.     Application.ScreenUpdating = True
  43.     MsgBox "筛选后的结果在 工作表 " & ActiveSheet.Name & " 中"
  44.     ActiveSheet.Previous.Select
  45. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2014-11-3 17:05 | 显示全部楼层
数据展开.rar (23.33 KB, 下载次数: 9)
回复

使用道具 举报

hwc2ycy
发表于 2014-11-3 17:10 | 显示全部楼层    本楼为最佳答案   
  1. Sub demo()
  2.     Dim arr, arr3(1 To 256, 1 To 12)
  3.     Dim i&, j&, k&, lRow&
  4.     Dim sht As Worksheet
  5.     Dim strPrefix$, lSn&

  7.     '源数据
  8.     arr = Range("a1").CurrentRegion
  9.     Application.ScreenUpdating = False
  10.     Set sht = Worksheets.Add(after:=ActiveSheet)
  11.     lRow = 2
  12.     '标题行
  13.     Range("a1").Resize(, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, 1)
  14.     '每一行原始记录
  15.     For i = 2 To UBound(arr)

  17.         strPrefix = Left(arr(i, 1), 2)        '序号前缀
  18.         lSn = Mid(arr(i, 1), 3) '起始序号
  19.         For j = 0 To arr(i, 2) - 1  '重复次数
  20.             For k = 3 To UBound(arr, 2)
  21.                 arr3(j + 1, 1) = strPrefix & lSn + j '3-12列数据写入新数组中
  22.                 arr3(j + 1, k) = arr(i, k) '新序号
  23.             Next
  24.         Next
  25.         arr3(1, 2) = arr(i, 2) '第一行第2列数量
  26.         If j Then
  27.             '写回到工作表中并设置格式
  28.             With Cells(lRow, 1).Resize(j, UBound(arr3, 2))
  29.                 .Value = arr3
  30.                 .Borders(xlDiagonalDown).LineStyle = xlNone
  31.                 .Borders(xlDiagonalUp).LineStyle = xlNone
  32.                 With .Borders
  33.                     .LineStyle = xlContinuous
  34.                 End With
  35.                 .Borders(xlInsideVertical).LineStyle = xlNone
  36.                 .Borders(xlInsideHorizontal).LineStyle = xlNone
  37.             End With
  38.             Erase arr3 '数组清空
  39.             lRow = lRow + j '行号
  40.         End If
  41.     Next
  42.     Application.ScreenUpdating = True
  43.     MsgBox "筛选后的结果在 工作表 " & ActiveSheet.Name & " 中"
  44.     ActiveSheet.Previous.Select
  45. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2014-11-3 18:45 | 显示全部楼层
忙好刚刚有空打开论坛，谢谢版主。
回复

使用道具 举报

 楼主| 发表于 2014-11-3 19:48 | 显示全部楼层
hwc2ycy 发表于 2014-11-3 17:10

加注释好啊！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-25 12:18 , Processed in 0.404937 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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