[已解决]批量查询多工作表各区间相同数组的问题

YangYangg · 发表于 2013-7-14 08:06

附件

wp8680 · 发表于 2013-7-14 10:01

这个问题，就是工作量太大。可以提供个思路给你：用字典,取出五列的数据为KEY,循环下一个，如果在字典里有，则提出字典中的ITEM,和提出本行，到SHEET0表中。再套上外循环每个区间，再外套上外循环每个工作表，再外套循环每个工作簿。
工作量太大，所以只好作罢。

hwc2ycy · 发表于 2013-7-14 10:03

Sub 遍历工作簿()
Dim strPath As String, strFile As String
strPath = ThisWorkbook.Path & Application.PathSeparator & "数据文件" & Application.PathSeparator
strFile = Dir(strPath & "*.xlsx")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do While Len(strFile)
If strFile <> ThisWorkbook.Name Then
Call 汇总(strPath & strFile)
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "查找结束"
End Sub
Sub 汇总(strFullname As String)
Dim i As Byte, k As Long
Dim lLastRow As Long, lRow As Long
Dim objwb As Workbook
Dim objDic As Object, objDicTemp As Object
Dim strKey As String, Key, Item
Dim arr, arrTemp
On Error GoTo ErrorHandler
Set objwb = GetObject(strFullname)
Windows(objwb.Name).Visible = True
Set objDic = CreateObject("scripting.dictionary")
lRow = 1
With objwb
For i = 1 To .Worksheets.Count - 1
With .Worksheets("sheet" & i)
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:p" & lLastRow).Value
End With
For k = LBound(arr) To UBound(arr)
If Not objDic.exists(arr(k, 4)) Then
objDic.Add arr(k, 4), CreateObject("scripting.dictionary")
End If
Set objDicTemp = objDic(arr(k, 4))
strKey = arr(k, 10) & "#" & arr(k, 11) & "#" & arr(k, 13) & "#" & arr(k, 14) & "#" & arr(k, 16)
objDicTemp(strKey) = objDicTemp(strKey) & k & ","
Set objDic(arr(k, 4)) = objDicTemp
Next
For Each Key In objDic.keys
Set objDicTemp = objDic(Key)
For Each Item In objDicTemp.items
With .Worksheets("sheet0")
If (Len(Item) - Len(Replace(Item, ",", ""))) > 1 Then
arrTemp = Split(Item, ",")
For k = LBound(arrTemp) To UBound(arrTemp) - 1
.Cells(lRow, 1).Resize(, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, arrTemp(k), 0)
lRow = lRow + 1
Next
.Cells(lRow - 1, 18).Value = Key
lRow = lRow + 1
End If
End With
Next
Next
objDic.RemoveAll
Next
.Close True
End With
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbOKCancel, IIf(objwb Is Nothing, "", objwb.Name)
If Not objwb Is Nothing Then
objwb.Close False
End If
End Sub

复制代码

hwc2ycy · 发表于 2013-7-14 10:03

你的1，2貌似数据都是一样的吧，我看SHEET0得出的结果是一样的。

你给验证下。

hwc2ycy · 发表于 2013-7-14 10:09

貌似最好中的区间跟你的不同了，我写的是文件名了，得再改下。

hwc2ycy · 发表于 2013-7-14 10:12

没看清，我填的是区间名，你要求的是表名。

Sub 遍历工作簿()
Dim strPath As String, strFile As String
strPath = ThisWorkbook.Path & Application.PathSeparator & "数据文件" & Application.PathSeparator
strFile = Dir(strPath & "*.xlsx")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do While Len(strFile)
If strFile <> ThisWorkbook.Name Then
Call 汇总(strPath & strFile)
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "查找结束"
End Sub
Sub 汇总(strFullname As String)
Dim i As Byte, k As Long
Dim lLastRow As Long, lRow As Long
Dim objwb As Workbook
Dim objDic As Object, objDicTemp As Object
Dim strKey As String, Key, Item
Dim arr, arrTemp
On Error GoTo ErrorHandler
Set objwb = GetObject(strFullname)
Windows(objwb.Name).Visible = True
Set objDic = CreateObject("scripting.dictionary")
lRow = 1
With objwb
For i = 1 To .Worksheets.Count - 1
With .Worksheets("sheet" & i)
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:p" & lLastRow).Value
End With
For k = LBound(arr) To UBound(arr)
If Not objDic.exists(arr(k, 4)) Then
objDic.Add arr(k, 4), CreateObject("scripting.dictionary")
End If
Set objDicTemp = objDic(arr(k, 4))
strKey = arr(k, 10) & "#" & arr(k, 11) & "#" & arr(k, 13) & "#" & arr(k, 14) & "#" & arr(k, 16)
objDicTemp(strKey) = objDicTemp(strKey) & k & ","
Set objDic(arr(k, 4)) = objDicTemp
Next
For Each Key In objDic.keys
Set objDicTemp = objDic(Key)
For Each Item In objDicTemp.items
With .Worksheets("sheet0")
If (Len(Item) - Len(Replace(Item, ",", ""))) > 1 Then
arrTemp = Split(Item, ",")
For k = LBound(arrTemp) To UBound(arrTemp) - 1
.Cells(lRow, 1).Resize(, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, arrTemp(k), 0)
lRow = lRow + 1
Next
.Cells(lRow - 1, 18).Value = i
lRow = lRow + 1
End If
End With
Next
Next
objDic.RemoveAll
Next
.Close True
End With
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbOKCancel, IIf(objwb Is Nothing, "", objwb.Name)
If Not objwb Is Nothing Then
objwb.Close False
End If
End Sub

复制代码

hwc2ycy · 发表于 2013-7-14 10:12

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

批量查询各区间相同数组附件.rar (24.48 KB, 下载次数: 17)

YangYangg · 发表于 2013-7-14 10:41

hwc2ycy 发表于 2013-7-14 10:03
你的1，2貌似数据都是一样的吧，我看SHEET0得出的结果是一样的。

你给验证下。

谢谢老师帮助。试了一下真实数据。运行很正常。但与预期结果相差很大。即同一张工作薄，用非批量查询出来的数据，与用批量查询出来的数据，差别很大。仔细对比了一下，发现：批量查询，返回的结果，R列数工作表标识，成了区间标识。

R列的数据，是代表工作表的，即：47就是Sheet47 48就是Sheet48 , 这里发现，与D列的区间数全部都是相同的。

估计问题就出在这里。

hwc2ycy · 发表于 2013-7-14 11:09

后来的代码修正了这个。

YangYangg · 发表于 2013-7-14 11:11

hwc2ycy 发表于 2013-7-14 10:12
SHEET1里有个按钮，直接点按钮即可。

经测试，运行正常。只是结果的返回方式有点区别。对比了一下，批量查询速度快很多。决定取批量查询方式，而改变后续一个程序了。

谢谢老师帮助，再谢！

		自动登录	找回密码
密码			注册

[已解决]批量查询多工作表各区间相同数组的问题

相关帖子

评分