提取数据

张雄友

提取数据，整行提取。

qinzjbank

将原始数据时进行筛选，将筛选结果自制粘贴到新表即可。

张雄友

qinzjbank 发表于 2013-7-18 21:47
将原始数据时进行筛选，将筛选结果自制粘贴到新表即可。

不是一表，是多表，更新附件了。

bluexuemei

Sub bxm()
Dim sh, arr, brr(1 To 10000, 1 To 15), i, k
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "提取数据" Then
arr = sh.UsedRange
For i = 2 To sh.[a65536].End(3).Row
   If arr(i, 12) = "Q09" Then
     m = m + 1
     For k = 1 To UBound(arr, 2)
      brr(m, k) = arr(i, k)
     Next
   End If
Next
End If
Next
Worksheets("提取数据").[a2].Resize(m, 15) = brr
End Sub

张雄友

bluexuemei 发表于 2013-7-18 22:48
Sub bxm()
Dim sh, arr, brr(1 To 10000, 1 To 15), i, k
For Each sh In ThisWorkbook.Worksheets

"&Igrave;á&Egrave;&iexcl;&Ecirc;&yacute;&frac34;&Yacute;

大师，这是什么来的？不要吓我。

zhaogang1960

SQL联合查询，要求不超过49个工作表：

1. Sub Macro1()
   
2.     Dim cnn As Object, sh As Worksheet, SQL$
   
3.     Set cnn = CreateObject("adodb.connection")
   
4.     cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
   
5.     For Each sh In Sheets
   
6.      If sh.Name <> "提取数据" Then
   
7.         If SQL <> "" Then SQL = SQL & " union all "
   
8.         SQL = SQL & "select * from [" & sh.Name & "$] where 代码='Q09'"
   
9.      End If
   
10.     Next
    
11.     Cells.ClearContents
    
12.     [a1].CopyFromRecordset cnn.Execute(SQL)
    
13.     cnn.Close
    
14.     Set cnn = Nothing
    
15. End Sub
    
16. 
    

复制代码

zhaogang1960

请看附件
多表提取数据.rar (45.24 KB, 下载次数: 29)

2013-7-18 23:04 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2013-7-18 23:04
请看附件

版主，没有表头的？

bluexuemei

张雄友 发表于 2013-7-18 22:53
"&Igrave;á&Egrave;&iexcl;&Ecirc;&yacute;&frac34;&Yacute;

大师，这是什么来的？不要吓我。

乱码，已修改。

zhaogang1960

张雄友 发表于 2013-7-18 23:06
版主，没有表头的？

复制一个表头:
多表提取数据.rar (45.29 KB, 下载次数: 27)

2013-7-18 23:18 上传

点击文件名下载附件