Copy From Multiple Ranges

ir121973

Active Member
Joined
Feb 9, 2008
Messages
371
Hi, I wonder whether someone may be able to help me please.

Firstly, I'd like to apologise because my VB is not my strongest subject, so to some this may be a very basic error.

From a tutorial I've found, I've adapted the code (below) to allow the user to copy from multiple Excel files, combining them into one 'Master' spreadsheet.

Code:
Sub BigMerge()


Dim DestCell As Range
Dim DataColumn As Variant
Dim NumberOfColumns As Variant
Dim WB As Workbook
Dim DestWB As Workbook
Dim WS As Worksheet
Dim FileNames As Variant
Dim N As Long
Dim R As Range
Dim StartRow As Long
Dim Lastrow As Long
Dim RowNdx As Long
Dim r1, r2, myMultipleRange As Range


' Create a new workbook for the consolidated
' data.
'Set DestWB = Workbooks.Add
' OR use the ActiveWorkbook:
    Set DestWB = ActiveWorkbook
' OR use an open workbook
   ' Set DestWB = Workbooks("Book1.xls")
    
' DestCell is the first cell where the consolidated
' data will be written.
Set DestCell = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
With DestCell


'With .Borders(xlInsideVertical)
 '           .LineStyle = xlContinuous
 '           .Weight = xlHairline
 '           .ColorIndex = xlAutomatic
    '   End With
        With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
        End With
    End With
' DataColumn is the column on the worksheets to be
' consolidated where the actual data is. Data will
' be copied from this column.
DataColumn = "A"


' NumberOfColumns is the number of columns on each
' worksheet to be consolidated from which data will
' be copied. E.g., if your data is in range A1:J100,
' NumberOfColumns would be 10.
NumberOfColumns = 36


' StartRow is the row on the worksheets to be consolidated
' where the data starts. If your worksheet have heading/summary
' rows at the top, set this value to the row number where
' the actual data starts.
StartRow = 5




' Get the workbooks to consolidate
FileNames = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xls*", _
        Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
    If FileNames = False Then
        ' User cancelled open dialog. get out.
        Exit Sub
    End If
End If


' Loop through all the selected files.
For N = LBound(FileNames) To UBound(FileNames)
    ' Open the workbook
    Set WB = Workbooks.Open(Filename:=FileNames(N), ReadOnly:=True)
    ' Loop through all the worksheets in the workbook
    For Each WS In WB.Worksheets
        With WS
            ' Test if worksheet has content. It must have
            ' at least two cells with content. Otherwise,
            ' it is assumed to be empty and will not be
            ' processed.
            If WS.UsedRange.Cells.Count > 1 Then
                ' Get the last row in DataColumn
                ' that has data.
                Lastrow = .Cells(.Rows.Count, DataColumn). _
                    End(xlUp).Row
                ' Loop through the rows, statring at StartRow
                ' and going down to LastRow.
                For RowNdx = StartRow To Lastrow
                    ' Copy the cells on row RowNdx
                    ' starting in DataColumn for NumberOfColumns'
                    ' columns wide. Data is copied to
                    ' DestCell.
                    .Cells(RowNdx, DataColumn). _
                            Resize(1, NumberOfColumns).Copy _
                            Destination:=DestCell
    
       
                    ' Move the DestCell down one row.
                    Set DestCell = DestCell(2, 1)
                Next RowNdx
            End If
        End With
    Next WS
    ' close the workbook.
    WB.Close savechanges:=False
Next N


End Sub
The macro works fine when it is copying the data from one range, but I'd now like to add to this and copy data from another range within the same sheet. The two ranges are A:AJ and AL:AX.

In it's current form, the section of script below deals with the setting of the range, but I'm really unsure about how to adapt this to include the second range.


Code:
' DataColumn is the column on the worksheets to be
' consolidated where the actual data is. Data will
' be copied from this column.
DataColumn = "A"


' NumberOfColumns is the number of columns on each
' worksheet to be consolidated from which data will
' be copied. E.g., if your data is in range A1:J100,
' NumberOfColumns would be 10.
NumberOfColumns = 36


' StartRow is the row on the worksheets to be consolidated
' where the data starts. If your worksheet have heading/summary
' rows at the top, set this value to the row number where
' the actual data starts.
StartRow = 5


Could someone perhaps offer a little guidance please on how I may go about copying the data from two, rather than the one range please.

Any help would be gratefully received.

Many thanks and kind regards
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
The macro works fine when it is copying the data from one range, but I'd now like to add to this and copy data from another range within the same sheet. The two ranges are A:AJ and AL:AX.
A:AJ and AL:AX are columns, what about start row and rows number ?
 
Upvote 0
Hi @patel5 thank you for taking the time to reply to my post.

My sincere apologies for not making this clear. The row that I would like this to start from is row 5 and then copy down until a blank row is reached.

Many thanks and kind regards

Chris
 
Upvote 0
Code:
Sub BigMerge()
Set DestWB = ActiveWorkbook
Dim DestCell As Range
DataColumn = "A"
NumberOfColumns = 36
StartRow = 5
FileNames = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xls*", _
        Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
    If FileNames = False Then
        Exit Sub
    End If
End If
For N = LBound(FileNames) To UBound(FileNames)
    Set WB = Workbooks.Open(Filename:=FileNames(N), ReadOnly:=True)
    For Each WS In WB.Worksheets
        With WS
            If .UsedRange.Cells.Count > 1 Then
               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
               Lastrow = .UsedRange.Rows.Count
               Range("A" & StartRow & ":AK" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, 1)
               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
               Range("AL" & StartRow & ":AX" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, 1)
            End If
        End With
    Next WS
    WB.Close savechanges:=False
Next N
End Sub
 
Upvote 0
Hi, thank you very much for taking the time to reply and put the solution together.

Unfortunately I'm unable to get this to work correctly. When I paste the data into the 'Master sheet', the column headers are deleted from row 5 and the second range is pasted underneath the first rather than on the same rows.

Many thanks and kind regards
 
Upvote 0
I can not test your wb, attach a link to your files with current and desired sheets
 
Upvote 0
Hi, ir121973,

lines for copying underneath are:
Rich (BB code):
               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
               Lastrow = .UsedRange.Rows.Count
               Range("A" & StartRow & ":AK" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, 1)
               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
               Range("AL" & StartRow & ":AX" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, 1)
as always Column A is refered to.

Maybe you change the code to read
Rich (BB code):
               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
               Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
               .Range("A" & Startrow & ":AK" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, "A")
'               dr = DestWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
               .Range("AL" & Startrow & ":AX" & Lastrow).Copy DestWB.Worksheets(1).Cells(dr, "AL")
If you want no free column in between the two ranges please change AL to Ak.

Ciao,
Holger
 
Upvote 0
Hi @HaHoBe, thank you very much for taking the time to reply to my post and put this together, it works great.

Many thanks and kind regards

Chris
 
Upvote 0
Hi @patel45, please see the post I received from @HaHoBe, which together with the script you posted works great.

Thank you very much for taking the time to put the solution together.

Many thanks and kind regards
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

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