Need help creating a conditional copy macro for Excel 2003

Question

I would like to conditionally copy data from multiple worksheets into a single worksheet in a given workbook in order to consolidate data. The macro would look at column F in all the worksheets, and if a row in column F matches a given number, that row gets copeid. Any help would be great!!

Terry

Answer 1

How about:

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