需要帮助创buildExcel 2003的条件副本macros

我想有条件地将多个工作表中的数据复制到给定工作簿中的单个工作表中，以合并数据。 macros将查看所有工作表中的列F，并且如果列F中的某一行匹配给定的数字，则该行将变得非常复杂。 任何帮助将是伟大的！

特里

Answer 1

怎么样：

Dim cn As Object Dim rs As Object Dim ws As Worksheet Dim wb As Workbook Dim sSQL As String Dim sFile As String Dim sCon As String Dim sXLFileToProcess As String sXLFileToProcess = "Book1.xls" strFile = Workbooks(sXLFileToProcess).FullName '' Note that if HDR=No, F1,F2 etc are used for column names, '' if HDR=Yes, the names in the first row of the range '' can be used. '' This is the Jet 4 connection string, you can get more '' here : http://www.connectionstrings.com/excel sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";" '' Late binding, so no reference is needed Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open sCon '' In this example, the column header for column F is F, see notes '' above on field (column) names. It also assumes that the sheets to '' be merged have the same column headers in the same order '' It would be safer to list the column heards rather than use *. For Each ws In Workbooks(sXLFileToProcess).Worksheets sSQL = sSQL & "SELECT * FROM [" & ws.Name & "$] " _ & "WHERE f=3 " _ & "UNION ALL " Next sSQL = Left(sSQL, Len(sSQL) - 10) rs.Open sSQL, cn, 3, 3 '' New workbook for results Set wb = Workbooks.Add With wb.Worksheets("Sheet1") '' Column headers For i = 1 To rs.Fields.Count .Cells(1, i) = rs.Fields(i - 1).Name Next '' Selected rows .Cells(2, 1).CopyFromRecordset rs End With '' Tidy up rs.Close Set rs = Nothing cn.Close Set cn = Nothing