vba combining excel file content. Need to combine multiple row instead of range

anreda

New Member
Joined
Jul 18, 2018
Messages
5
Hi to all,
I found a vba script that I changed a little to copy a row content from multiple excel workbooks into one.
this is working. It adds A52:Z52 into one excel from all files selected.

What I would like to do is change this script in a way that I can copy a few rows from each workbook.

In the example vba I select the content of row A52:Z52 but would like to add A55:Z55 for example.

Can this be done in this vba script?

Code:
Sub CombineSCTMD()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:"
       
    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath
    
    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1
    
    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)
        
        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)
        
        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName
        
        ' Set the source range to be B13 through K down to last row.
        ' Modify this range for your workbooks. It can span multiple rows.
        Dim LastRow As Long
    LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
                 After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
                 SearchDirection:=xlPrevious, _
                 LookIn:=xlFormulas, _
                 SearchOrder:=xlByRows).Row
    'Set SourceRange = WorkBk.Worksheets(1).Range("B13:Z" & LastRow)
    Set SourceRange = WorkBk.Worksheets(1).Range[COLOR=#FF0000]("A52:Z52")[/COLOR]
       
        ' Set the destination range to start at column B and be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
    Next NFile
    
    ' Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
    
   'Insert 1 Rows Above Row 1
    Rows("1:1").Insert Shift:=xlDown, _
      CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

' Write FolderPath in cel A1
'Range("A1").Value = FolderPath
End Sub
 
Last edited by a moderator:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
anreda,

Welcome to the Board.

You might consider modifying this line...

Code:
Set SourceRange = WorkBk.Worksheets(1).Range("A52:Z52")

to...

Code:
Set SourceRange = Union(WorkBk.Worksheets(1).Range("A52:Z52"), WorkBk.Worksheets(1).Range("A55:Z55"))

Cheers,

tonyyy
 
Upvote 0
Hi Tonyyy,
thanks a lot for your reply.
I tried this union function but it only returns the first selected range A52:Z52 for some reason.
BR Ad
 
Upvote 0
A copy/paste might be more effective than a DestRange.Value = SourceRange.Value...

Code:
Sub CombineSCTMD()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:"
       
    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath
    
    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1
    
    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)
        
        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)
        
        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName
        
        ' Set the source range to be B13 through K down to last row.
        ' Modify this range for your workbooks. It can span multiple rows.
        Dim LastRow As Long
    LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
                 After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
                 SearchDirection:=xlPrevious, _
                 LookIn:=xlFormulas, _
                 SearchOrder:=xlByRows).Row
    'Set SourceRange = WorkBk.Worksheets(1).Range("B13:Z" & LastRow)
[COLOR=#ff0000]    Set SourceRange = Application.Union(Worksheets(1).Range("A52:Z52"), Worksheets(1).Range("A55:Z55"))
    SourceRange.Copy[/COLOR]
    
        ' Set the destination range to start at column B and be the same size as the source range.
[COLOR=#ff0000]        Set DestRange = SummarySheet.Range("B" & NRow)
        Application.Goto DestRange
        ActiveSheet.Paste[/COLOR]
        
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
    Next NFile
    
    ' Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
    
   'Insert 1 Rows Above Row 1
    Rows("1:1").Insert Shift:=xlDown, _
      CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

' Write FolderPath in cel A1
'Range("A1").Value = FolderPath
End Sub
 
Upvote 0
Hi,
It must be me not too familiar with vba. I tried your suggestion but it runs into error. The debug shows:
-- corrupted image removed --
I could send you a few excel files if I knew how to attache them
 
Last edited by a moderator:
Upvote 0
The debug shows:

Is there an Error Number? Error Description?
Which line of code is highlighted when the error occurs?

And to cover the basics... Are you on a PC or Mac? Which version of Excel?
 
Upvote 0
Hi Tonyyy
I am running W7 PC with office 365.
Maybe I played too much with my vba before. After you reply I tried again but got different result.
after running the vba it first comes with the question if I would like to store the large amount on the clipboard for later use, because of the copy function.
If you confirm with yes it seems to copy both rows. At the next file you get the same question on the clipboard and again both rows are copied. Only the paste is just going down one row and therefore overwrites one of the former rows. So only the last file has both rows.
Seems the copy function is working but it doesn't paste it below the last row that was pasted. hope I coud make clear what happens.
 
Upvote 0
Try replacing this...
Code:
NRow = NRow + DestRange.Rows.Count

With this...
Code:
NRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row + 1

And if you want to suppress the question to save the clipboard, add this line above the Dim statements...
Code:
Application.DisplayAlerts = False
 
Upvote 0
Hi Tonyyy,
this is working perfectly. It will make things a LOT easier. I need to dig into the vba a bit more and learn. But your help here is really appreciated!
many thanks. my regards, Ad
 
Upvote 0

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top