TesmoKava Ответов: 2

Объедините 10 XLS файлов в один

Всем привет

У меня есть 10 XLS-отчетов по 8 столбцов в каждом.

Все файлы содержат одинаковые имена столбцов.

Мне нужно объединить их в один xls-файл.

нужна помощь, чтобы продолжить.

Что я уже пробовал:

Я решил использовать приведенную ниже ссылку

ТПС://ВСП.codeproject.ком/советы/715976/решения для объединения нескольких в Excel-рабочие листы-инт

2 Ответов

Рейтинг:
14

Suvendu Shekhar Giri

Вот статья, которая может быть полезна, если вы хотите, чтобы ваши данные были на отдельных листах одного файла excel.
Как объединить несколько книг в одну книгу в Excel?[^]
и после
Как объединить рабочие листы / книги в один рабочий лист?[^]

Надеюсь, это поможет :)

TesmoKava

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

Рейтинг:
0

Pat O'Brien

Эта подпрограмма будет считывать все файлы xls* в папке, где сохранена эта основная рабочая книга. Он будет считывать все данные в "листе 1" всех этих файлов и добавлять данные из каждого из них в текущий рабочий лист.


Sub ReadXLFiles()
'set a reference (in Tools / References) to Microsoft ActiveX Data Objects
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strConnect As String
Dim strSQL As String
Dim recCount As Long
Dim ws As Worksheet
Dim wsTgt As Worksheet
Dim strFileName As String
Dim strFilePath As String
Dim bNeedToWriteHeaders As Boolean
Dim rngTgt As Range
Dim c As Integer

    On Error GoTo ErrorHandler
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Set wsTgt = ActiveSheet
    Set rngTgt = wsTgt.Range("A1")
    ' clear existing data
    rngTgt.CurrentRegion.Clear
    
    strFilePath = ActiveWorkbook.Path
    
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    strFileName = Dir(strFilePath & "\*.xls*")
    strSQL = "SELECT * FROM [Sheet1$]"
    ' assumes all workbooks have a "Sheet1" where the data is located
    recCount = 0
    bNeedToWriteHeaders = True
    Do While strFileName <> ""
        If strFileName <> ActiveWorkbook.Name Then
            Application.StatusBar = "Processing file: " & strFileName
            strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & "\" & strFileName & ";Extended Properties=Excel 12.0;Persist Security Info=False"
            
            cn.Open strConnect
            cn.CommandTimeout = 120
            
            'run the query
            rs.Open strSQL, cn, adOpenKeyset  'need this for record number
            If rs.RecordCount > 0 Then
                If bNeedToWriteHeaders Then
                    For c = 0 To rs.Fields.Count - 1
                        rngTgt.Offset(0, c) = rs.Fields(c).Name
                    Next
                    bNeedToWriteHeaders = False
                    recCount = recCount + 1
                End If
                'write the results
                rngTgt.Offset(recCount, 0).CopyFromRecordset rs
                'update position for next write
                recCount = recCount + rs.RecordCount
            End If
            DoEvents
            rs.Close
            cn.Close
        End If
        strFileName = Dir  ' get next file name
    
    Loop
    
    Set rs = Nothing
    Set cn = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
    
    MsgBox "Done.", vbExclamation, "Thanks Pat!"
Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbCritical, "I'm sorry Dave, I can't do that..."
End Sub