[已解决]复制或提取数据

张雄友 · 发表于 2013-7-18 21:48

w2001pf 发表于 2013-7-18 21:45
你发的附件就只有一个的，而且你的要求也没有说清楚的。如果需要做再继续发问吧？

见附件。

hwc2ycy · 发表于 2013-7-18 21:52

直接用SQL不更方便嘛。

张雄友 · 发表于 2013-7-18 21:53

hwc2ycy 发表于 2013-7-18 21:52
直接用SQL不更方便嘛。

用SQL导入数据，单表的可以，多表的不能吧？据我所知。

hwc2ycy · 发表于 2013-7-18 22:08

Const adUseClient = 3
Const adModeShareDenyWrite = 8
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object, AdoRst As Object
Sub 提取数据()
Dim sht As Worksheet
Dim strSql As String
Dim strCode As String
strCode = Application.InputBox("请输入要查找的代码字段值，注意大小写", Type:=2)
If strCode = "False" Then
MsgBox "没有输入字段或没有确定，结束"
Exit Sub
End If
For Each sht In Worksheets
If sht.Name <> "提取数据" Then
strSql = strSql & "select * from [" & sht.Name & "$] where 代码='" & strCode & "' union all "
End If
Next
If Len(strSql) Then
strSql = Left(strSql, Len(strSql) - 11)
If ADOQuery(ThisWorkbook.FullName, strSql) Then
With Worksheets("提取数据")
Dim lLastRow&
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
If lLastRow > 1 Then
.Range("a2:o" & lLastRow).ClearContents
End If
.Range("a2").CopyFromRecordset AdoRst
End With
MsgBox "查询完毕"
End If
End If
End Sub
Function ADOQuery(strFullname As String, Optional strSql As String, Optional blnHasHeader As Boolean = True) As Boolean
Dim StrConn$
Set AdoConn = CreateObject("ADODB.Connection")
Select Case Application.Version
Case "14.0", "12.0"
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
strFullname & "';Extended Properties='Excel 12.0;HDR=" & blnHasHeader & ";imex=1';"
Case Else
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
End Select
Debug.Print StrConn
On Error GoTo ErrorHandler
With AdoConn
.CommandTimeout = 5
.ConnectionTimeout = 5
.CursorLocation = adUseClient
.Mode = adModeRead 'Write 'adModeShareDenyWrite
.ConnectionString = StrConn
.Open
End With
Debug.Print strSql
Set AdoRst = AdoConn.Execute(strSql)
ADOQuery = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description
Set AdoRst = Nothing
Set AdoConn = Nothing
End Function

复制代码

张雄友 · 发表于 2013-7-18 22:11

hwc2ycy 发表于 2013-7-18 22:08

数据是提取出来了，只是没有表头。

hwc2ycy · 发表于 2013-7-18 22:16

改进下，插入一个模块，代码放入模块中，可在工作表中放一按钮，指定宏为提取数据

Const adUseClient = 3
Const adModeShareDenyWrite = 8
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object, AdoRst As Object
Sub 提取数据()
Dim sht As Worksheet
Dim strSql As String
Dim strCode As String
Dim lLastRow As Long
strCode = Application.InputBox("请输入要查找的代码字段值" & vbCrLf & vbCrLf & "请注意大小写", Type:=2)
If strCode = "False" Then
MsgBox "没有输入查询字段或没有确定，结束"
Exit Sub
End If
For Each sht In Worksheets
If sht.Name <> "提取数据" Then
strSql = strSql & "select * from [" & sht.Name & "$] where 代码='" & strCode & "' union all "
End If
Next
If Len(strSql) = 0 Then Exit Sub
strSql = Left(strSql, Len(strSql) - 11)
If ADOQuery(ThisWorkbook.FullName, strSql) Then
With Worksheets("提取数据")
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
If lLastRow > 1 Then
.Range("a2:o" & lLastRow).ClearContents
End If
If AdoRst.RecordCount > 0 Then
.Range("a2").CopyFromRecordset AdoRst
MsgBox "查询完毕" & vbCrLf & vbCrLf & "一共查询到 " & AdoRst.RecordCount & " 条记录", vbInformation + vbOKOnly
Else
MsgBox "没有查询到符合条件的数据" & vbCrLf & "请检查代码字段"
End If
End With
End If
End Sub
Function ADOQuery(strFullname As String, Optional strSql As String, Optional blnHasHeader As Boolean = True) As Boolean
Dim StrConn$
Set AdoConn = CreateObject("ADODB.Connection")
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
On Error GoTo ErrorHandler
With AdoConn
.CommandTimeout = 5
.ConnectionTimeout = 5
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = StrConn
.Open
End With
Set AdoRst = AdoConn.Execute(strSql)
ADOQuery = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description
Set AdoRst = Nothing
Set AdoConn = Nothing
End Function

复制代码

hwc2ycy · 发表于 2013-7-18 22:17

张雄友发表于 2013-7-18 22:11
数据是提取出来了，只是没有表头。

一样都可以的。

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

张雄友发表于 2013-7-18 22:11
数据是提取出来了，只是没有表头。

表头我懒得写了，你直接从SHEET1里复制一个过去放第一行就成了。
反正清除的时候第一行不会动。

张雄友 · 发表于 2013-7-18 22:23

hwc2ycy 发表于 2013-7-18 22:18
表头我懒得写了，你直接从SHEET1里复制一个过去放第一行就成了。
反正清除的时候第一行不会动。

strSql = strSql & "select * from [" & sht.Name & "$] where 代码='" & strCode & "' union all "

现在是查询代码的，如果要改查询工序号，就将代码改成工序号，能否将“ where 代码” 这句

改用通用的Application.InputBox 来可以供选择吗？这样就可以查，产量，工号，组别，等等......

hwc2ycy · 发表于 2013-7-18 22:29

再次改下，标题问题已经解决了。

Const adUseClient = 3
Const adModeShareDenyWrite = 8
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object, AdoRst As Object
Sub 提取数据()
Dim sht As Worksheet
Dim strSql As String
Dim strCode As String
Dim lLastRow As Long
Dim arrTitle()
Dim i As Long
strCode = Application.InputBox("请输入要查找的代码字段值" & vbCrLf & vbCrLf & "请注意大小写", Type:=2)
If strCode = "False" Then
MsgBox "没有输入查询字段或没有确定，结束"
Exit Sub
End If
For Each sht In Worksheets
With sht
If .Name <> "提取数据" Then
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
strSql = strSql & "select * from [" & sht.Name & "$A1:O" & lLastRow & "] where 代码='" & strCode & "' union all "
End If
End With
Next
If Len(strSql) = 0 Then Exit Sub
strSql = Left(strSql, Len(strSql) - 11)
If ADOQuery(ThisWorkbook.FullName, strSql) Then
With Worksheets("提取数据")
Application.ScreenUpdating = False
.UsedRange.ClearContents
ReDim arrTitle(1 To AdoRst.Fields.Count)
For i = 1 To UBound(arrTitle)
arrTitle(i) = AdoRst.Fields(i - 1).Name
Next
.Range("a1").Resize(, UBound(arrTitle)).Value = arrTitle
If AdoRst.RecordCount > 0 Then
.Range("a2").CopyFromRecordset AdoRst
MsgBox "查询完毕" & vbCrLf & vbCrLf & "一共查询到 " & AdoRst.RecordCount & " 条记录", vbInformation + vbOKOnly
Else
MsgBox "没有查询到符合条件的数据" & vbCrLf & "请检查代码字段"
End If
Application.ScreenUpdating = True
End With
End If
End Sub
Function ADOQuery(strFullname As String, Optional strSql As String, Optional blnHasHeader As Boolean = True) As Boolean
Dim StrConn$
Set AdoConn = CreateObject("ADODB.Connection")
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
On Error GoTo ErrorHandler
With AdoConn
.CommandTimeout = 5
.ConnectionTimeout = 5
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = StrConn
.Open
End With
Set AdoRst = AdoConn.Execute(strSql)
ADOQuery = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description
Set AdoRst = Nothing
Set AdoConn = Nothing
End Function

复制代码

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