Importing multiple identical ranges from other workbooks into summary workbook

[Grizz]

Hi,

I posted a thread a few days ago asking for some help on how to import a range of data from another workbook which would occur when a data validation drop down selected a week number and where the range was selected dynamically from a couple of vlookups. tehneXus was a great help and provided the answer perfectly, it did exactly as I wanted, the original thread is here:

http://www.excelforum.com/excel-prog...45#post3273345

When I want to import the range for week 20 and week 20 is selected on the data validation cell B4 my current file selects rows 9177 to 9198 from cells D4 and E4 and imports columns A to AZ from the first workbook "Cell 1 availability". I probably didn't think far enough ahead when I posted the original thread as I need to do this from 34 workbooks. The cell layouts in all 34 workbooks are identical so for week 20 the range will always be rows 9177 through to 9198. How can I modify the code to insert the same size range for "Cell 2 availability" into D29 below the first import and so on until "Cell 34 availability"?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xlWbSrc As Workbook, xlWsSrc As Worksheet
    Dim xlCalulation As Long
    
    On Error GoTo ErrorHandler
    
    If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        xlCalulation = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    If WbOpen("Cell 1 Availability.xls") Then
        Set xlWbSrc = Workbooks("Cell 1 Availability.xls")      'Change filename for each testcell's file
    Else
        Set xlWbSrc = Workbooks.Open(Filename:="G:\Cell 1 Availability.xls")    'adapt path for each cell's file and filename
    End If
    
    If WsExists("daily", xlWbSrc) Then
        Set xlWsSrc = xlWbSrc.Worksheets("daily") 'change sheetname if not 'daily'
    Else
        MsgBox "Worksheet 'daily' is missing in '" & xlWbSrc.Name & "'.", vbInformation + vbOKOnly, "Error"
        GoTo ErrorHandler
    End If
    
    xlWsSrc.Range("A" & Range("D4").Value & ":AZ" & Range("E4").Value).Copy Destination:=Range("D7")
    xlWbSrc.Close False
ErrorHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "Error"
    End If
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalulation
    End With
End Sub

Thanks for any help on this,

Grizz

[Grizz]

I've managed to sort this out now...

[arlu1201]

If you solve a problem yourself before anyone else has responded, please take a moment to describe your solution, chances are some other member will benefit.

[Grizz]

Hi, the solution was already in the code, I just had to duplicate the right parts and adjust some of the cell references, but you're right I should have explained that...

I duplicated this part of the code, changing the file name and path to the next workbook and the destination Cell from D7 to the new reference:

If WbOpen("Cell 1 Availability.xls") Then
        Set xlWbSrc = Workbooks("Cell 1 Availability.xls")      'Change filename for each testcell's file
    Else
        Set xlWbSrc = Workbooks.Open(Filename:="G:\Cell 1 Availability.xls")    'adapt path for each cell's file and filename
    End If
    
    If WsExists("daily", xlWbSrc) Then
        Set xlWsSrc = xlWbSrc.Worksheets("daily") 'change sheetname if not 'daily'
    Else
        MsgBox "Worksheet 'daily' is missing in '" & xlWbSrc.Name & "'.", vbInformation + vbOKOnly, "Error"
        GoTo ErrorHandler
    End If
    
    xlWsSrc.Range("A" & Range("D4").Value & ":AZ" & Range("E4").Value).Copy Destination:=Range("D7")
    xlWbSrc.Close False