Copy a range based on dynamic row numbers and paste into another workbook

**Grizz** · 06-09-2013, 10:15 AM

Hi,

I'm looking to copy a range of 22 rows from columns A through to AZ on a different closed workbook and bring them into the active workbook and I'd like to be able to do it in VBA if possible. The closed workbook has at the moment about 10,000 rows. On the active workbook in cell B4 I have a data validation drop-down where the week number can be selected and then in D4 and E4 I have a couple of Vlookups that find the row numbers that need to be copied for the particular week number in B4. In my example file you can see an example of how I want to import the 22 rows. If I select a different week I would like the data over written in the same place.

I'd be very grateful for any help on this, I've managed to get the data in using Index Match formulas but because the files are located on a server to which the file paths are quite long the formulas look very messy. I enjoy working on formulas but my VBA is no where near the same level unfortunately.

Thanks in advance..

**tehneXus** · 06-09-2013, 11:02 AM

Hi,

try the files attached: support.zip

You'll have to adapt the file/sheet name and path of the sourcefile, if not open the macro will open the file and close it afterwards.

File contains in the worksheet module:

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("Source.xlsx") Then
        Set xlWbSrc = Workbooks("Source.xlsx")      'adapt filename
    Else
        Set xlWbSrc = Workbooks.Open(Filename:="X:\Documents\Programming\Excel\support\Source.xlsx")    'adapt path and filename
    End If
    
    If WsExists("SourceSheet", xlWbSrc) Then
        Set xlWsSrc = xlWbSrc.Worksheets("SourceSheet")
    Else
        MsgBox "Worksheet 'SourceSheet' 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("B7")
    
    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

and in a standard module

Function WsExists(ByVal wsName As String, Optional xlWb As Excel.Workbook) As Boolean
    On Error Resume Next
    Dim xlWs As Worksheet
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    Set xlWs = xlWb.Worksheets(wsName)
    WsExists = (Err = 0)
    Set xlWs = Nothing
End Function

Function WbOpen(ByVal wbName As String) As Boolean
    On Error Resume Next
    Dim xlWb As Workbook
    Set xlWb = Application.Workbooks(wbName)
    WbOpen = (Err = 0)
    Set xlWb = Nothing
End Function