ExcelMerger/ExcelMergerMacro at master · RatqSciTech/ExcelMerger · GitHub

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
Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim newSheetName As String
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                 If WorksheetFunction.CountA(wksCurSheet.UsedRange) = 0 And wksCurSheet.Shapes.Count = 0 Then
                  wksCurSheet.Delete
                  Else

                    countSheets = countSheets + 1
                    newSheetName = wksCurSheet.Name & "-" & Left(wbkSrcBook.Name, InStr(wbkSrcBook.Name, ".") - 1)
                    If (Len(newSheetName) > 31) Then
                    newSheetName = Left(newSheetName, 31)
                    End If
                    wksCurSheet.Name = newSheetName
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                      End If

                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

  For Each wksCurSheet In wbkCurBook.Sheets
  If WorksheetFunction.CountA(wksCurSheet.UsedRange) = 0 And wksCurSheet.Shapes.Count = 0 Then
                  wksCurSheet.Delete
                  End If
                  Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub