需要帮助为 Excel 2003 创建条件复制宏

Question

我想有条件地将多个工作表中的数据复制到给定工作簿中的单个工作表中，以合并数据。该宏将查看所有工作表中的 F 列，如果 F 列中的一行与给定数字匹配，则该行将获得 copid。任何帮助都会很棒！

特里

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