[已解决]单张查询改批量查询的问题

YangYangg · 发表于 2013-7-10 18:03

附件

提取数据附件.rar (141.93 KB, 下载次数: 12)

hwc2ycy · 发表于 2013-7-10 22:00

查询到的所有结果汇总到代码所在工作簿的SHEET0里?

hwc2ycy · 发表于 2013-7-10 22:21

插入一个模块，贴粘代码。

Sub CommandButton1_Click()
Dim strPath As String, strFile As String
strPath = ThisWorkbook.Path & Application.PathSeparator & "数据文件" & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do While Len(strFile)
If strFile <> ThisWorkbook.Name Then
Call Query(strPath & strFile)
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "汇总完成"
Application.StatusBar = ""
End Sub
Sub Query(strFullname As String)
Dim objwb As Workbook
Dim objsh As Worksheet
Dim objDst As Worksheet
Dim arr, i&, j&
Set objwb = GetObject(strFullname)
Set objDst = ThisWorkbook.Worksheets("sheet0")
Windows(objwb.Name).Visible = True
Application.StatusBar = strFullname
For Each objsh In objwb.Worksheets
With objsh
If .Name <> "Sheet0" Then
arr = .Range(.Cells(1, 1), .Cells(.[a65536].End(3).Row, .[iv1].End(1).Column)).Value
For i = 1 To UBound(arr)
For j = i + 1 To UBound(arr)
If arr(i, 4) = arr(j, 4) And arr(i, 10) = arr(j, 10) And arr(i, 11) = arr(j, 11) And arr(i, 13) = arr(j, 13) And arr(i, 14) = arr(j, 14) And arr(i, 16) = arr(j, 16) Then
objDst.Cells([b65536].End(3).Row + 2, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, i, 0)
objDst.Cells([b65536].End(3).Row + 1, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, j, 0)
objDst.Cells([b65536].End(3).Row, 18) = Right(.Name, Len(.Name) - 5)
End If
Next j
Next i
End If
End With
Next objsh
objwb.Close False
End Sub

复制代码

hwc2ycy · 发表于 2013-7-10 22:22

没做容错处理。

YangYangg · 发表于 2013-7-10 22:40

hwc2ycy 发表于 2013-7-10 22:22
没做容错处理。

谢谢老师帮助。查询到的结果，应返回各自的工作薄的Sheet0里。

hwc2ycy · 发表于 2013-7-10 22:53

Sub Query(strFullname As String)
Dim objwb As Workbook
Dim objsh As Worksheet
Dim objDst As Worksheet
Dim arr, i&, j&
Set objwb = GetObject(strFullname)
Set objDst = objwb.Worksheets("sheet0")
Windows(objwb.Name).Visible = True
Application.StatusBar = strFullname
For Each objsh In objwb.Worksheets
With objsh
If .Name <> "Sheet0" Then
arr = .Range(.Cells(1, 1), .Cells(.[a65536].End(3).Row, .[iv1].End(1).Column)).Value
For i = 1 To UBound(arr)
For j = i + 1 To UBound(arr)
If arr(i, 4) = arr(j, 4) And arr(i, 10) = arr(j, 10) And arr(i, 11) = arr(j, 11) And arr(i, 13) = arr(j, 13) And arr(i, 14) = arr(j, 14) And arr(i, 16) = arr(j, 16) Then
objDst.Cells([b65536].End(3).Row + 2, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, i, 0)
objDst.Cells([b65536].End(3).Row + 1, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, j, 0)
objDst.Cells([b65536].End(3).Row, 18) = Right(.Name, Len(.Name) - 5)
End If
Next j
Next i
End If
End With
Next objsh
objwb.Close False
End Sub

复制代码

你试下，替换这个过程。
这个过程改了几个字而已。

YangYangg · 发表于 2013-7-10 23:17

hwc2ycy 发表于 2013-7-10 22:53
你试下，替换这个过程。
这个过程改了几个字而已。

谢谢老师。试了一下，能正常运行，但无结果。

附件

查询.rar (439.83 KB, 下载次数: 14)

hwc2ycy · 发表于 2013-7-11 06:55

忘了，你看最后一句是CLOSE FALSE，{:1012:}

Sub Query(strFullname As String)
Dim objwb As Workbook
Dim objsh As Worksheet
Dim objDst As Worksheet
Dim arr, i&, j&
Set objwb = GetObject(strFullname)
Set objDst = objwb.Worksheets("sheet0")
Windows(objwb.Name).Visible = True
Application.StatusBar = strFullname
For Each objsh In objwb.Worksheets
With objsh
If .Name <> "Sheet0" Then
arr = .Range(.Cells(1, 1), .Cells(.[a65536].End(3).Row, .[iv1].End(1).Column)).Value
For i = 1 To UBound(arr)
For j = i + 1 To UBound(arr)
If arr(i, 4) = arr(j, 4) And arr(i, 10) = arr(j, 10) And arr(i, 11) = arr(j, 11) And arr(i, 13) = arr(j, 13) And arr(i, 14) = arr(j, 14) And arr(i, 16) = arr(j, 16) Then
objDst.Cells([b65536].End(3).Row + 2, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, i, 0)
objDst.Cells([b65536].End(3).Row + 1, 1).Resize(, UBound(arr, 2)) = Application.Index(arr, j, 0)
objDst.Cells([b65536].End(3).Row, 18) = Right(.Name, Len(.Name) - 5)
End If
Next j
Next i
End If
End With
Next objsh
objwb.Close TRUE
End Sub

复制代码

YangYangg · 发表于 2013-7-11 07:40

hwc2ycy 发表于 2013-7-11 06:55
忘了，你看最后一句是CLOSE FALSE，

谢谢老师帮助。试了一下，出现无限循环。查了工作薄1，接着查工作薄2，再1，再2，再1，再2，停不下来。

hwc2ycy · 发表于 2013-7-11 08:49

应该不会啊。上面的循环不会死的。

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