[已解决]指定工作薄批量查询指定数据的问题

dfshm · 发表于 2013-12-2 18:45

本帖最后由 dfshm 于 2013-12-2 21:45 编辑

附件

指定工作薄批量查询指定数据.rar (95.25 KB, 下载次数: 13)

yyyydddd8888 · 发表于 2013-12-2 20:51

请测试：

指定工作薄批量查询指定数据.zip (202.69 KB, 下载次数: 22)

dfshm · 发表于 2013-12-2 21:15

yyyydddd8888 发表于 2013-12-2 20:51
请测试：

老师您好，谢谢您帮助，试了一下，发现只能查询三组数据。加了第四组就没有结果了。实际中，要查询的，不只附件中的三组数据，而有一百多组。相应也要保存一百多个文件。

不知能否麻烦您修改一下，谢谢了。

dfshm · 发表于 2013-12-2 21:21

yyyydddd8888 发表于 2013-12-2 20:51
请测试：

如图

yyyydddd8888 · 发表于 2013-12-2 21:29

本帖最后由 yyyydddd8888 于 2013-12-2 21:44 编辑

dfshm 发表于 2013-12-2 21:21
如图

知道了，原来不知道你有这么多数据。现在改一下。
用下面的附件应该可以：

指定工作薄批量查询指定数据.zip (261.66 KB, 下载次数: 3)

2013-12-2 21:44 上传

点击文件名下载附件

Sub test()
Dim arr1, arr2, crr, r&, myname$, i As Byte, j As Byte, k As Byte, m As Byte, n As Byte, x&, y As Byte, lastrow&
Dim mypath$, wb As Workbook, sh As Worksheet, z As Integer
Set wb = ThisWorkbook
r = wb.sheets(1).Range("a65536").End(xlUp).Row
Application.DisplayAlerts = False
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\数据"
For j = 2 To r Step 4
For i = 1 To 11
arr1 = wb.Sheets("sheet1").Range(Cells(j - 1, i), Cells(j + 1, i))
arr2 = wb.Sheets("sheet1").Range(Cells(j, "m"), Cells(j, "o"))
For m = 1 To UBound(arr2, 2)
If arr2(1, m) <> "" Then
With Workbooks.Open(mypath & arr2(1, m) & ".xls")
With .Sheets(1)
For n = 1 To .Cells(2, 256).End(xlToLeft).Column
lastrow = .Cells(65536, 1).End(xlUp).Row
crr = .Range(.Cells(1, n), .Cells(lastrow, n))
For x = 1 To UBound(crr) - 2
If crr(x, 1) = arr1(1, 1) And crr(x + 1, 1) = arr1(2, 1) And crr(x + 2, 1) = arr1(3, 1) Then
k = k + 1
wb.Sheets("sheet" & i + 1).Cells(1, k).Resize(UBound(crr)) = crr
wb.Sheets("sheet" & i + 1).Cells(UBound(crr) + 1, k) = arr2(1, m) & "(" & n & ")"
Exit For
End If
Next x
Next n
End With
.Close False
End With
End If
Next m
k = 0
Next i
wb.SaveCopyAs ThisWorkbook.Path & "\0" & Application.RoundUp(j / 4, 0) & ".xls"
With Workbooks.Open(ThisWorkbook.Path & "\0" & Application.RoundUp(j / 4, 0) & ".xls")
.Sheets(1).Rows.Clear
.Close True
End With
For y = 2 To 12
wb.Sheets(y).Rows.Clear
Next y
Next j
MsgBox "数据提取完毕"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
End Sub

复制代码

dfshm · 发表于 2013-12-2 21:36

yyyydddd8888 发表于 2013-12-2 21:29
知道了，原来不知道你有这么多数据。现在改一下。
用下面的附件应该可以：

老师您好，试了一下，这下连查都查不了了。提示：对象或属性方法错误。

yyyydddd8888 · 发表于 2013-12-2 21:40

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

单击隐藏图章

本帖最后由 yyyydddd8888 于 2013-12-2 21:42 编辑

dfshm 发表于 2013-12-2 21:36
老师您好，试了一下，这下连查都查不了了。提示：对象或属性方法错误。

不好意思，掉了一个sheets(1)

现在修改好了，请再测试：

修改指定工作薄批量查询指定数据.zip (261.66 KB, 下载次数: 27)

dfshm · 发表于 2013-12-2 21:48

yyyydddd8888 发表于 2013-12-2 21:40
不好意思，掉了一个sheets(1)
现在修改好了，请再测试：

谢谢老师帮助。
数据文件夹下，工作薄的格式，其实都是07版的。列数有16380，不知能否读过去。明天再测试了。

再次谢谢，祝好人一生平安！

yyyydddd8888 · 发表于 2013-12-2 21:56

r = wb.sheets(1).Range("a65536").End(xlUp).Row
中的行数改为07版的行数，
把列数比如：
For n = 1 To .Cells(2, 256).End(xlToLeft).Column
中的256改为16380变成：For n = 1 To .Cells(2, 16380).End(xlToLeft).Column

dfshm · 发表于 2013-12-2 22:07

yyyydddd8888 发表于 2013-12-2 21:56
r = wb.sheets(1).Range("a65536").End(xlUp).Row
中的行数改为07版的行数，
把列数比如：

谢谢！

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

[已解决]指定工作薄批量查询指定数据的问题

评分