Excel 2003 용 조건부 복사 매크로를 만드는 데 도움이 필요합니다.

Question

데이터를 통합하기 위해 조건에 ​​따라 여러 통합 문서의 단일 워크 시트에 여러 워크 시트의 데이터를 복사하고 싶습니다. 매크로는 모든 워크 시트에서 F 열을보고, F 열의 행이 주어진 수와 일치하면 그 행은 copeid가됩니다. 어떤 도움이 좋을지 !!

테리

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