Faster meathod for linking ranges in local workbook to a remote workbook

[thechazm]

Hello All,

I have been trying to figure out a faster meathod to link a range in the local workbook with a range on a remote workbook through vba. I have created a few functions but it just seems slow. The reason why I need this is lets say you only wanted to look at 4 items from 11,000 items in a different workbook is what I am trying to achive.

Here is my code if anyone can shed some light please.

Function LinkCell(strFileName As String, strSheetName As String, strCell As String) As String
Dim strFile As String, strTmp As String
strFile = Mid(strFileName, InStrRev(strFileName, "\") + 1, Len(strFileName) - InStrRev(strFileName, "\"))
strTmp = strFileName
strTmp = Left(strTmp, (InStrRev(strTmp, "\")))
strFileName = strTmp
LinkCell = "='" & strFileName & "[" & strFile & "]" & strSheetName & "'!" & strCell
End Function

Function SelectedProjects()
'FastVBA
'On Error GoTo ErrHandler
Dim xlsRemoteApp As Excel.Application, xlsRemoteWB As Excel.Workbook, xlsRemoteSheet As Excel.Worksheet, xlsApp As Excel.Application, xlsWB As Excel.Workbook, xlsSheet As Excel.Worksheet
Dim xlsRef As Excel.Worksheet, xlsModify As Excel.Worksheet, dDateRan As Boolean
Dim doNotImportNN() As Long, FindRng As Excel.Range, doNotImportNU() As Long, cRange As Excel.Range, LastAddress As String, cCol As Long
ReDim doNotImportNN(2 To 999)
ReDim doNotImportNU(2 To 999)
Set xlsApp = Application
Set xlsWB = xlsApp.Workbooks(1)
Set xlsSheet = xlsWB.Worksheets("Select Projects")
Set xlsRef = xlsWB.Worksheets("Ref")
For i = 2 To xlsRef.Cells(xlsSheet.Rows.Count, "A").End(xlUp).Row
    cCol = 1
    Set xlsRemoteApp = New Excel.Application
    Set xlsRemoteWB = xlsRemoteApp.Workbooks.Open(xlsRef.Cells(i, 2))
    Set xlsRemoteSheet = xlsRemoteWB.Worksheets(1)
    
    ' Adds the referenced date from the first 700 to all the sheets
    If xlsRef.Cells(i, 1) = 700 And dDateRan = False Then
        detectDateRange xlsRemoteApp, xlsRemoteWB, xlsRemoteSheet, "Selected Projects NN"
        detectDateRange xlsRemoteApp, xlsRemoteWB, xlsRemoteSheet, "Selected Projects NU"
        detectDateRange xlsRemoteApp, xlsRemoteWB, xlsRemoteSheet, "OPW NN"
        detectDateRange xlsRemoteApp, xlsRemoteWB, xlsRemoteSheet, "OPW NU"
        dDateRan = True
    End If
    
    ' Sets whether the data is nuclear or not.
    If InStr(1, xlsRef.Cells(i, 3), "Non") > 0 And xlsRef.Cells(i, 1) = 700 Then
        Set xlsModify = xlsWB.Worksheets("Selected Projects NN")
        ' Locate selected projects and store the row numbers in doNotImportNN Array
        For ii = 2 To xlsSheet.Cells(xlsSheet.Rows.Count, "A").End(xlUp).Row Step 1
            Set FindRng = xlsRemoteSheet.Cells.Find(xlsSheet.Cells(ii, 1), , , xlWhole)
            For Each R In FindRng
'                doNotImportNN(ii) = xlsRemoteSheet.Cells.Find(xlsSheet.Cells(ii, 1), , , xlWhole).Row
                doNotImportNN(ii) = R.Row
                LastAddress = xlsRemoteSheet.Range("C" & doNotImportNN(ii) & ":BB" & doNotImportNN(ii)).End(xlToRight).Address
                Set cRange = xlsRemoteSheet.Range("A" & doNotImportNN(ii) & ":" & LastAddress)
                For Each c In cRange
                    xlsModify.Cells(ii, cCol).Formula = LinkCell(xlsRemoteApp.CommandBars("Web").Controls("Address:").Text, xlsRemoteSheet.Name, c.Address)
                    cCol = cCol + 1
                Next c
                cCol = 1
            Next R
        Next ii
'    Else
'        Set xlsModify = xlsWB.Worksheets("Selected Projects NU")
'        ' Locate selected projects and store the row numbers in doNotImportNU Array
'        For ii = 2 To xlsSheet.Cells(xlsSheet.Rows.Count, "A").End(xlUp).Row Step 1
'            doNotImportNU(ii) = xlsRemoteSheet.Cells.Find(xlsSheet.Cells(ii, 1), , , xlWhole).Row
'        Next ii
    End If
    
    
    
    
    Set FindRng = Nothing
    Set xlsRemoteSheet = Nothing
    xlsRemoteWB.Close False
    Set xlsRemoteWB = Nothing
    xlsRemoteApp.Quit
    Set xlsRemoteApp = Nothing
    
Next i
Set xlsRef = Nothing
Set xlsSheet = Nothing
Set xlsWB = Nothing
Set xlsApp = Nothing
'SlowVBA
'Exit Function
'
'ErrHandler:
'
'SlowVBA
'MsgBox Err.Number & " - " & Err.Description
'Set xlsRef = Nothing
'Set xlsSheet = Nothing
'Set xlsWB = Nothing
'Set xlsApp = Nothing
End Function

Function detectDateRange(xlsRemoteApp As Excel.Application, xlsRemoteWB As Excel.Workbook, xlsRemoteSheet As Excel.Worksheet, strSheetName As String)
Dim LastAddress As String
Dim xlsSheet As Excel.Worksheet, xlsApp As Excel.Application, xlsWB As Excel.Workbook
Set xlsApp = Application
Set xlsWB = xlsApp.Workbooks(1)
Set xlsSheet = xlsWB.Worksheets(strSheetName)
LastAddress = xlsRemoteSheet.Range("C1:BB1").End(xlToRight).Address
For Each R In xlsRemoteSheet.Range("$C$1:" & LastAddress)
    xlsSheet.Range(R.Address).Formula = LinkCell(xlsRemoteApp.CommandBars("Web").Controls("Address:").Text, xlsRemoteSheet.Name, R.Address)
Next R
Set xlsSheet = Nothing
Set xlsWB = Nothing
Set xlsApp = Nothing
End Function