MS Excel - Макросы для объединения значений из нескольких листов в один лист - PullRequest
Новая
       14

MS Excel - Макросы для объединения значений из нескольких листов в один лист

1 голос
/ 27 апреля 2010

Считайте, что у меня есть 4 рабочие книги со следующей структурой ... 

1. Main.xlsx
    Name    Jan   Feb  Mar
       A
       B
       C

2. Jan.xlsx       
     Name     Jan
      A       3.3
      B       6.4
      C       5.3

3. Feb.xlsx       
     Name     Feb
      A       1.3
      B       3.4
      C       5.5

4. Mar.xlsx       
     Name     Mar
      A       1.3
      B       3.4
      C       5.5

Мне нужно объединить их как 

1. Main.xlsx
        Name    Jan   Feb  Mar
           A    3.3   1.3  1.3
           B    6.4   3.4  3.4
           C    5.3   5.5  5.5

И мне нужно автоматизировать процесс ...

И я думаю, я могу сделать это с помощью макросов ...? Кто-нибудь может предложить какой-нибудь способ, с помощью которого я могу продолжить работу с макросом?

Спасибо за ваше время ....

1 Ответ

0 голосов
/ 27 апреля 2010

Вы можете использовать ADO. Вот некоторые заметки. 

''Must use macro-enabled file type, eg .xlsm
''The code was run from Main.xlsm, but should work in any 
''Excel file.
Dim fs As Object
Dim rs As Object
Dim cn As Object
Dim strSQL As String
Dim strCon As String
Dim i, f, s, m, ml
Dim aFiles As Variant

''For looking up files, Dir would work, too
Set fs = CreateObject("Scripting.FileSystemObject")

''Array for file names and month names
''Space for months up to one less than the current month
ReDim aFiles(Month(Date) - 2, 1)

''Fill the array ...
For i = 1 To Month(Date) - 1

    ''With files called mmm.xlsx ...
    m = Format(CDate("2010/" & i & "/1"), "mmm")
    ''Found in C:\Docs
    f = "C:\Docs\" & m & ".xlsx"

    ''Checking first that the file exists
    If fs.FileExists(f) Then
        aFiles(i - 1, 0) = f
        aFiles(i - 1, 1) = m
    Else
        Debug.Print "Missing : " & f
    End If
Next

''Build the SQL string ...
For i = 1 To UBound(aFiles, 1)
    ''For joins, brackets = number of months -1
    strSQL = strSQL & "("
Next

''Using Main.xlsm subquery as the basis for all Names ...
strSQL = strSQL & "(SELECT [Name] FROM [Sheet1$] IN '' " _
   & "[Excel 8.0;database=C:\docs\Main.xlsm]) As Main LEFT JOIN "

''Left Join to all found files as subqueries aliased as mmm name ...
For i = 0 To UBound(aFiles, 1)
    strSQL = strSQL & "(SELECT [Name]," & aFiles(i, 1) _
         & " FROM [Sheet1$] IN '' [Excel 8.0;database=" _
    & aFiles(i, 0) & "]) AS " & aFiles(i, 1) & " ON Main.Name = " & aFiles(i, 1) 
         & ".Name) LEFT JOIN "
Next

''Remove final Left Join and bracket ...
strSQL = Left(strSQL, Len(strSQL) - 12)

''Get a list of months ...
For i = 0 To UBound(aFiles, 1)
    ml = ml & "," & aFiles(i, 1)
Next

''Add the outer query, and that is the SQL string finished.
strSQL = "SELECT Main.Name," & Mid(ml, 2) & " FROM " & strSQL

''This uses main.xlsm in the connection string, but it is
''not important which file is used because the SQL string
''is build using IN (keyword) to get the various files
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
    & Workbooks("main.xlsm").FullName _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''Connection and recordset objects
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

rs.Open strSQL, cn

''Fill heading into Sheet2
For i = 0 To rs.Fields.Count - 1
    Sheets("Sheet2").Cells(1, i + 1) = rs.Fields(i).Name
Next

''Fill data into Sheet2
Sheets("Sheet2").Cells(2, 1).CopyFromRecordset rs
...