Нужна помощь в создании макроса условной копии для Excel 2003 - PullRequest
Новая
       1

Нужна помощь в создании макроса условной копии для Excel 2003

1 голос
/ 16 июля 2010

Я хотел бы условно скопировать данные из нескольких рабочих листов в одну рабочую таблицу в данной рабочей книге для консолидации данных.Макрос будет смотреть на столбец F во всех листах, и если строка в столбце F соответствует заданному числу, эта строка становится копейдной.Любая помощь будет великолепна !!

Терри

1 Ответ

1 голос
/ 16 июля 2010

Как насчет: 

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
...