Merge Beberapa File Excel dalam satu Sheet

Tulisan ini hanya untuk mengingat ingat saja jika suatu saat nanti saya lupa. Bagi pembaca yang kebetulan memerlukannya silahkan diaplikasi. Semoga membantu proses verifikasi data dari pada copy paste manual akan membutuhkan waktu lebih lama.

1. Pada Tab DEVELOPER klick Insert > Command Buttom

2. Jika berhasil akan tampil seperti ini:

3. Tekan Alt + F11

4. Copy tag berikut ini, lalu paste pada sheet code:

Sub mergeAllworkbooks()

    Dim MyPath As String, FilesInPath As String

    Dim MyFiles() As String

    Dim SourceRcount As Long, FNum As Long

    Dim mybook As Workbook, BaseWks As Worksheet

    Dim sourceRange As Range, destrange As Range

    Dim rnum As Long, CalcMode As Long

   ' Change this to the path\folder location of your files.

    MyPath = "C:\Documents and Settings\My Documents\Audit Inv 2015\PN- MUTASI 2"

    ' Add a slash at the end of the path if needed.

    If Right(MyPath, 1) <> "\" Then

        MyPath = MyPath & "\"

    End If

    ' If there are no Excel files in the folder, exit.

    FilesInPath = Dir(MyPath & "*.xl*")

    If FilesInPath = "" Then

        MsgBox "No files found"

        Exit Sub

    End If

    ' Fill the myFiles array with the list of Excel files

    ' in the search folder.

    FNum = 0

    Do While FilesInPath <> ""

        FNum = FNum + 1

        ReDim Preserve MyFiles(1 To FNum)

        MyFiles(FNum) = FilesInPath

        FilesInPath = Dir()

    Loop

    ' Set various application properties.

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

        .EnableEvents = False

    End With

    ' Add a new workbook with one sheet.

    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    rnum = 1

    ' Loop through all files in the myFiles array.

    If FNum > 0 Then

        For FNum = LBound(MyFiles) To UBound(MyFiles)

            Set mybook = Nothing

            On Error Resume Next

            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))

            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                ' Change this range to fit your own needs.

                With mybook.Worksheets(1)

                    Set sourceRange = .Range("A1:K200")

                End With

                If Err.Number > 0 Then

                    Err.Clear

                    Set sourceRange = Nothing

                Else

                    ' If source range uses all columns then

                    ' skip this file.

                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then

                        Set sourceRange = Nothing

                    End If

                End If

                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then

                         MsgBox "There are not enough rows in the target worksheet."

                        BaseWks.Columns.AutoFit

                        mybook.Close savechanges:=False

                        GoTo ExitTheSub

                    Else

                        ' Copy the file name in column A"

                        With sourceRange

                            BaseWks.Cells(rnum, "A").Resize(.Rows.Count).Value = MyFiles(FNum)

                           

                        End With

                        ' Set the destination range.

                        Set destrange = BaseWks.Range("B" & rnum)

                        ' Copy the values from the source range

                        ' to the destination range.

                        With sourceRange

                                Set destrange = destrange.Resize(.Rows.Count, .Columns.Count)

                                       

                                           

                        End With

                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount

                    End If

                End If

                mybook.Close savechanges:=False

            End If

        Next FNum

        BaseWks.Columns.AutoFit

    End If

ExitTheSub:

    ' Restore the application properties.

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

        .Calculation = CalcMode

    End With

End Sub

5. Click run atau F5 setelah menyesuaikan direktory data sourch, dan jumlah row yang akan dicopy