Excel精英培训网

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

[已解决]同一工作薄内多表提取数据问题

[复制链接]
发表于 2013-6-5 17:01 | 显示全部楼层 |阅读模式
附件 历遍工作表提取同类数据附件.rar (128.17 KB, 下载次数: 11)
发表于 2013-6-5 17:07 | 显示全部楼层
回复

使用道具 举报

发表于 2013-6-5 17:10 | 显示全部楼层
凡是F列的数相同,并且G列表号也相同

这个F列的数跟哪个数相同,G列表号又与哪个相同?
你得把依据说清楚点。

回复

使用道具 举报

 楼主| 发表于 2013-6-5 17:35 | 显示全部楼层
hwc2ycy 发表于 2013-6-5 17:10
凡是F列的数相同,并且G列表号也相同

这个F列的数跟哪个数相同,G列表号又与哪个相同?

F列,是从1--49的自然数
G列,是工作表的标识。

所谓F列的数相同,并且G列工作表标识(表号)相同,满足这两个条件都,即提出来.
有个问题忽略了:这种相同,是指在同一张工作表中,而不是全部工作表。

比如在Sheet1里就有这组

17
7
80
67
13
7
94
68
1
Sheet47
17
32
59
25
13
26
14
26
1
Sheet47


谢谢老师关注。
回复

使用道具 举报

发表于 2013-6-5 18:10 | 显示全部楼层    本楼为最佳答案   
  1. Sub 整理()
  2.     Dim iSheetNumber As Integer
  3.     Dim lLastRow&, i As Long, lRecord As Long, j As Long, k As Long
  4.     Dim objDic1 As Object, objDic2 As Object, strKey$, item1
  5.     Dim arrResult(), arr, arrTemp
  6.     On Error GoTo ErrorHandler


  7.     Application.ScreenUpdating = False
  8.     Application.DisplayAlerts = False
  9.     Application.EnableEvents = False
  10.     Application.Calculation = xlCalculationManual
  11.     Columns("a:g").ClearContents

  12.     For iSheetNumber = 2 To Worksheets.Count
  13.         With Worksheets(iSheetNumber)
  14.             lLastRow = .Cells(Rows.Count, "g").End(xlUp).Row
  15.             arr = .Range("a1:g" & lLastRow).Value
  16.         End With

  17.         ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))

  18.         Set objDic2 = CreateObject("scripting.dictionary")
  19.         Set objDic1 = CreateObject("scripting.dictionary")

  20.         For i = LBound(arr) + 1 To UBound(arr) Step 3
  21.             strKey = arr(i, 6) & "#" & arr(i, 7)
  22.             'Debug.Print strKey
  23.             objDic1(strKey) = objDic1(strKey) + 1
  24.             objDic2(strKey) = objDic2(strKey) & i & ","
  25.         Next

  26.         For Each item1 In objDic1.keys
  27.             If objDic1(item1) >= 2 Then
  28.                 arrTemp = Split(objDic2(item1), ",")
  29.                 For i = LBound(arrTemp) To UBound(arrTemp) - 1
  30.                     lRecord = lRecord + 1
  31.                     k = arrTemp(i)
  32.                     For j = LBound(arr, 2) To UBound(arr, 2)
  33.                         arrResult(lRecord, j) = arr(k - 1, j)
  34.                         arrResult(lRecord + 1, j) = arr(k, j)
  35.                     Next
  36.                     lRecord = lRecord + 2
  37.                 Next
  38.             End If
  39.         Next
  40.         With Worksheets(1)
  41.             If lRecord > 0 Then
  42.                 lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  43.                 If lLastRow > 1 Then lLastRow = lLastRow + 2
  44.                 .Cells(lLastRow, 1).Resize(lRecord, UBound(arrResult, 2)).Value = arrResult
  45.             End If
  46.         End With
  47.         'Stop
  48.         lRecord = 0
  49.         Set objDic1 = Nothing
  50.         Set objDic2 = Nothing
  51.         Erase arr
  52.     Next

  53.     Application.ScreenUpdating = True
  54.     Application.DisplayAlerts = True
  55.     Application.EnableEvents = True

  56.     Application.Calculation = xlCalculationAutomatic
  57.     MsgBox "整理完成"
  58.     Exit Sub

  59. ErrorHandler:
  60.     MsgBox Err.Number & vbCrLf & _
  61.            Err.Description
  62.     Application.ScreenUpdating = True
  63.     Application.DisplayAlerts = True
  64.     Application.EnableEvents = True
  65.     Application.Calculation = xlCalculationAutomatic
  66. End Sub
复制代码
回复

使用道具 举报

发表于 2013-6-5 18:16 | 显示全部楼层
  1. Sub 整理2()
  2.     Dim iSheetNumber As Integer
  3.     Dim lLastRow&, i As Long, lRecord As Long, j As Long, k As Long
  4.     Dim objDic1 As Object, objDic2 As Object, strKey$, item1
  5.     Dim arrResult(), arr, arrTemp
  6.     Dim t#
  7.     On Error GoTo ErrorHandler
  8.     t = Timer

  9.     Application.ScreenUpdating = False
  10.     Application.DisplayAlerts = False
  11.     Application.EnableEvents = False
  12.     Application.Calculation = xlCalculationManual
  13.     Columns("a:g").ClearContents
  14.    
  15.     '字典对像
  16.     Set objDic2 = CreateObject("scripting.dictionary")
  17.     Set objDic1 = CreateObject("scripting.dictionary")

  18.     '工作表循环
  19.     For iSheetNumber = 2 To Worksheets.Count
  20.         '读数据
  21.         With Worksheets(iSheetNumber)
  22.             lLastRow = .Cells(Rows.Count, "g").End(xlUp).Row
  23.             arr = .Range("a1:g" & lLastRow).Value
  24.         End With

  25.         '结果数组
  26.         ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))

  27.         '字典对像,可以放在外围,用REMOVE清空即可,
  28.         'Set objDic2 = CreateObject("scripting.dictionary")
  29.         'Set objDic1 = CreateObject("scripting.dictionary")

  30.         '字典1装出现资料,字典2装再现时所在的行号
  31.         For i = LBound(arr) + 1 To UBound(arr) Step 3
  32.             strKey = arr(i, 6) & "#" & arr(i, 7)
  33.             objDic1(strKey) = objDic1(strKey) + 1
  34.             objDic2(strKey) = objDic2(strKey) & i & ","
  35.         Next

  36.         For Each item1 In objDic1.keys
  37.             '找出重复的数据,生成结果数组
  38.             If objDic1(item1) >= 2 Then
  39.                 arrTemp = Split(objDic2(item1), ",")
  40.                 For i = LBound(arrTemp) To UBound(arrTemp) - 1
  41.                     lRecord = lRecord + 1
  42.                     k = arrTemp(i)
  43.                     For j = LBound(arr, 2) To UBound(arr, 2)
  44.                         arrResult(lRecord, j) = arr(k - 1, j)
  45.                         arrResult(lRecord + 1, j) = arr(k, j)
  46.                     Next
  47.                     lRecord = lRecord + 2
  48.                 Next
  49.             End If
  50.         Next
  51.         With Worksheets(1)
  52.             If lRecord > 0 Then
  53.                 lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  54.                 If lLastRow > 1 Then lLastRow = lLastRow + 2
  55.                 .Cells(lLastRow, 1).Resize(lRecord, UBound(arrResult, 2)).Value = arrResult
  56.             End If
  57.         End With
  58.         lRecord = 0
  59.         'Set objDic1 = Nothing
  60.         'Set objDic2 = Nothing
  61.         objDic1.RemoveAll
  62.         objDic2.RemoveAll
  63.         Erase arr
  64.     Next

  65.     Application.ScreenUpdating = True
  66.     Application.DisplayAlerts = True
  67.     Application.EnableEvents = True

  68.     Application.Calculation = xlCalculationAutomatic
  69.     t = Timer - t
  70.     MsgBox "整理完成" & vbCrLf & "一共用时 " & t & " 秒"
  71.     Exit Sub

  72. ErrorHandler:
  73.     MsgBox Err.Number & vbCrLf & _
  74.            Err.Description
  75.     Application.ScreenUpdating = True
  76.     Application.DisplayAlerts = True
  77.     Application.EnableEvents = True
  78.     Application.Calculation = xlCalculationAutomatic
  79. End Sub
复制代码
回复

使用道具 举报

发表于 2013-6-5 18:18 | 显示全部楼层
历遍工作表提取同类数据附件.rar (166.42 KB, 下载次数: 25)

评分

参与人数 1 +1 收起 理由
greenday + 1

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-6-5 18:20 | 显示全部楼层
hwc2ycy 发表于 2013-6-5 18:18

谢谢老师,试了一下,效果奇佳!
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 01:13 , Processed in 0.598282 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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