Excel Macro [Visual Basic] Merge only a few cells of every 1st worksheet, of multiple workbooks in a folder

Question

I use the following visual basic to select multiple excel workbooks in a folder, and merge them into the second worksheet of my active workbook.

In the actual code example it merges the complete range "as is", including all columns, rows and blanco cells. I only need to use the copied data of a few cells (B3, B5, B7 & E48) from first sheet in the selected workbooks, and paste them in only one row per merged workbook on the second sheet.

How can I prevent the macro from writing all these unnecessary data in the destination sheet? Or, at least, how can I combine a range of B3:E48 into one row in the destination sheet?

    Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub


Sub MergeSpecificWorkbooks()
    Dim MyPath 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
    Dim SaveDriveDir As String
    Dim FName As Variant


    ' Set application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ' Change this to the path\folder location of the files.
    ChDirNet "H:\xlstest"

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then

        ' Add a new workbook with one sheet.
        'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        'prevent prompting new workbook, write data in active sheet number two
        Set BaseWks = ActiveWorkbook.Worksheets(2)
        rnum = 1


        ' Loop through all files in the myFiles array.
        For FNum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("B5:E48")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If the 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 = FName(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
    ChDirNet SaveDriveDir
End Sub

This code is based on Ron de Bruin's merging examples, actually none of all other relevant internet sources provide a solution.

did you try anything by yourself? did you understand the code you've copy-pasted? — JMax
Am I missing something, or why do you use a Windows API to change the current directory when VBA provides the ChDir Statement for that? — JimmyPena

Tim Williams Tim Williams · Accepted Answer · 2011-11-18T00:15:25

This will give you some idea of how to create a non-contiguous range, and how to loop through and copy its values to a single row.

Sub Tester()

Dim a As Range, c As Range
Dim rngSrc As Range, rngDest As Range
Dim x As Long

    Set rngSrc = ActiveSheet.Range("B3,B5,B7,E48")
    Set rngDest = ActiveSheet.Range("A1")

    x = 0
    For Each a In rngSrc.Areas
        For Each c In a.Cells
            x = x + 1
            rngDest.Offset(0, x - 1).Value = c.Value
        Next c
    Next a

End Sub

Excel Macro [Visual Basic] Merge only a few cells of every 1st worksheet, of multiple workbooks in a folder

1 Answers