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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 历遍工作表用代码拆分数据重新组合的问题
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1818|回复: 4

[已解决]历遍工作表用代码拆分数据重新组合的问题

[复制链接]
greenday
发表于 2013-5-22 08:32 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
附件 拆分数据附件.rar (245.18 KB, 下载次数: 26)
工作表

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-5-22 09:38 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub 重新组合()
  2.     Dim lWorksheet As Long
  3.     Dim arr, arrNew
  4.     Dim lLastRow&
  5.     Dim rg As Range
  6.     Dim t#
  7.     t = Timer
  8.     Application.ScreenUpdating = False
  9.     For lWorksheet = 2 To Worksheets.Count
  10.         With Worksheets(lWorksheet)
  11.             lLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
  12.             Set rg = .Range(.[a1], .Cells(lLastRow, 55))
  13.             arr = rg.Value
  14.             arrNew = arrCombine(arr)
  15.             rg.ClearContents
  16.             .Range("a1").Resize(UBound(arrNew), UBound(arrNew, 2)).Value = arrNew
  17.         End With
  18.     Next
  19.     Application.ScreenUpdating = True
  20.     t = Timer - t
  21.     MsgBox "组合完成" & vbCrLf & _
  22.             "一共用时 " & t & " 秒", vbInformation + vbOKOnly
  23. End Sub

  25. Function arrCombine(arr)
  26.     Dim i As Long, j As Long, k As Long
  27.     'Dim arrNew(1 To 10000, 1 To 55)
  28.     Dim arrNew()
  29.     Dim lArrL&, lArrU&, lArrU2&, lCount&
  30.     Dim btCon As Byte
  31.     lArrL = LBound(arr)
  32.     lArrU = UBound(arr)
  33.     ReDim arrNew(1 To (lArrU ^ 2 - lArrU) / 2 * 3, 1 To 55)
  34.     lArrU2 = UBound(arr, 2)
  35.     For i = lArrL To lArrU
  36.         For j = i + 1 To lArrU
  37.             lCount = lCount + 1
  38.             For k = 1 To lArrU2
  39.                 arrNew(lCount, k) = arr(i, k)
  40.             Next
  41.             lCount = lCount + 1
  42.             For k = 1 To lArrU2
  43.                 arrNew(lCount, k) = arr(j, k)
  44.             Next
  45.             lCount = lCount + 1
  46.         Next
  47.     Next
  48.     arrCombine = arrNew
  49. End Function
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-5-22 09:38 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
你现有的表，在我电脑上是40-60秒，中间运行的时候，可能没有反应，也不要管他。
回复

使用道具 举报

hwc2ycy
发表于 2013-5-22 09:43 | 显示全部楼层    本楼为最佳答案   
  1. Sub 重新组合()
  2.     Dim lWorksheet As Long
  3.     Dim arr, arrNew
  4.     Dim lLastRow&
  5.     Dim rg As Range
  6.     Dim t#
  7.     t = Timer
  8.     On Error GoTo ErrorHandler
  9.     Application.ScreenUpdating = False
  10.     Application.Calculation = xlCalculationManual
  11.     Application.EnableEvents = False

  13.     For lWorksheet = 2 To Worksheets.Count
  14.         With Worksheets(lWorksheet)
  15.             lLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
  16.             Set rg = .Range(.[a1], .Cells(lLastRow, 55))
  17.             arr = rg.Value
  18.             arrNew = arrCombine(arr)
  19.             If IsArray(arrNew) Then
  20.                 rg.ClearContents
  21.                 .Range("a1").Resize(UBound(arrNew), UBound(arrNew, 2)).Value = arrNew
  22.             End If
  23.         End With
  24.     Next
  25.    
  26.     Application.ScreenUpdating = True
  27.     Application.Calculation = xlCalculationAutomatic
  28.     Application.EnableEvents = True

  30.     t = Timer - t
  31.     MsgBox "组合完成" & vbCrLf & _
  32.            "一共用时 " & t & " 秒", vbInformation + vbOKOnly
  33.     Exit Sub

  35. ErrorHandler:
  36.     MsgBox Err.Number & vbCrLf & _
  37.            Err.Description
  38. End Sub

  40. Function arrCombine(arr)


  43.     Dim i As Byte, j As Byte, k As Integer
  44.     'Dim arrNew(1 To 10000, 1 To 55)
  45.     Dim arrNew()
  46.     Dim lArrL&, lArrU&, lArrU2&, lCount&

  48.     On Error GoTo ErrorHandler

  50.     lArrL = LBound(arr)
  51.     lArrU = UBound(arr)
  52.     ReDim arrNew(1 To (lArrU ^ 2 - lArrU) / 2 * 3, 1 To 55)
  53.     lArrU2 = UBound(arr, 2)
  54.     For i = lArrL To lArrU
  55.         For j = i + 1 To lArrU
  56.             lCount = lCount + 1
  57.             For k = 1 To lArrU2
  58.                 arrNew(lCount, k) = arr(i, k)
  59.             Next
  60.             lCount = lCount + 1
  61.             For k = 1 To lArrU2
  62.                 arrNew(lCount, k) = arr(j, k)
  63.             Next
  64.             lCount = lCount + 1
  65.         Next
  66.     Next
  67.     arrCombine = arrNew
  68.     Exit Function

  70. ErrorHandler:
  71.     MsgBox Err.Number & vbCrLf & _
  72.            Err.Description
  73.     Err.Clear
  74.     arrCombine = ""
  75. End Function
复制代码

评分

参与人数 1 +1 收起 理由
greenday + 1 很给力!

查看全部评分

回复

使用道具 举报

greenday
 楼主| 发表于 2013-5-22 10:24 | 显示全部楼层
hwc2ycy 发表于 2013-5-22 09:43

谢谢老师帮助。再谢！
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-19 17:48 , Processed in 0.398520 second(s), 18 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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