Макрос для объединения нескольких файлов excel в один файл

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
                  (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
                   MultiSelect:=True, Title:="Files to Merge")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        GoTo ExitHandler
    End If
    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

Sub FiziK()
 
Const strStartDir = "c:test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:testresult" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = True  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy clTarget
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

Sub Собираем_диапазоны_выбранных_книг_и_всех_листов()
    
    Dim iRng As Range
    Dim iRngAddress As String, oAwb As String, oFile
    Dim lLastRow As Long, lLastRowMyBook As Long
    Dim iLastColumn As Integer
    Dim Str() As String
     
     
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = "*.*"
        .Title = "Выберите файлы"
    If .Show = False Then Exit Sub
    For Each oFile In .SelectedItems
        Workbooks.OpenText fileName:=oFile
        oAwb = Dir(oFile, vbDirectory)
     
        Application.ScreenUpdating = False
        Workbooks(oAwb).Activate
    For Each Sheet In Sheets
        Sheet.Activate
        lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
        iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
        lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
        iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
        Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)
         
    Next Sheet
        Workbooks(oAwb).Close False
    Next oFile
     
    End With
     
    Application.ScreenUpdating = True
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

Sub ww()
Const strStartDir = "C:UsersttDesktop"
Const strSaveDir = "C:UsersttDesktop"
Const blInsertNames = True
Dim a As Integer
Dim b As Integer
 
Dim r As String
r = InputBox("111", "aa")
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
On Error Resume Next
ChDir strStartDir
On Error GoTo 0
With Application
arFiles = .GetOpenFilename(FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
If Not IsArray(arFiles) Then End
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
.ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
    
For i = 1 To UBound(arFiles)
    .StatusBar = "12 " & i & " ?? " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
If IsNull(shSrc.UsedRange.Text) Then
Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
clTarget = "" & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(0, 1)
            End If
            Cells.Find(What:=r, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
        a = ActiveCell.Row
        b = ActiveCell.Column
        
            shSrc.Range(a, b).Copy clTarget
        End If
    Next
    wbSrc.Close False
    
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
On Error Resume Next
 
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("name", "Excel Files (*.xls), *.xls", , "aasd")
End With
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

Sub ww()
Const strStartDir = "C:UsersDesktop"
Const strSaveDir = "C:UsersDesktop"
Const blInsertNames = True
Dim r As String
r = InputBox("Data", "Inputs")
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
On Error Resume Next
ChDir strStartDir
On Error GoTo 0
With Application
arFiles = .GetOpenFilename(FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
If Not IsArray(arFiles) Then End
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
.ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
    
For i = 1 To UBound(arFiles)
    .StatusBar = "12 " & i & " ?? " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
    
 
    
If IsNull(shSrc.UsedRange.Text) Then
Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
            Cells.Find(What:=r, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
a = ActiveCell.Row
b = ActiveCell.Column
clTarget = "" & wbSrc.Name
                Set clTarget = clTarget.Offset(0, 1)
            End If
            shSrc.Cells(a, b + 1).Copy clTarget
            
        End If
    Next
    wbSrc.Close False
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
On Error Resume Next
 
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("name", "Excel Files (*.xls), *.xls", , "????????? ???????????? ?????")
 
If VarType(arFiles) = vbBoolean Then
GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Not saved", vbCritical
End With
 
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

Sub FiziK()
 
Const strStartDir = "c:test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:testresult" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = True  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy clTarget
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

Sub FiziK()
 
Const strStartDir = "C:UsersBurnoutmanDesktopXLSX"
Const strSaveDir = "C:UsersBurnoutmanDesktopXLSX"
Const blInsertNames = True
 
Dim wbTarget, wbSrc, shSrc, shTarget, arFiles,i, stbar, clTarget
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy clTarget
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub

1

Set wbTarget = thisworkbook