Assign Arrays from different workbooks

[Stephen Spittal]

Good Evening all,

I am looking for some help to speed things up i have 12 Subs following the code below, which assigns the given workbook/sheet/range to an 2D Array but this takes some time.

Thesize of the ranges are variable based on the range in the given workbooks and they dont all start on the 1st row.

Can this be done any quicker?

Thank you for your help in advance

Sub dosomething()
    Dim EDPFULL() As Variant
    fPath = stayWB.Path
    wName = "dashboard_edp_v_basic.csv"
    sName = "dashboard_edp_v_basic"
    rge = "A2:AC"
    EDPFULL() = GetArray(fPath, wName, sName, [rge], [EDP])
    close_workbook (wName)
End Sub

Public Function GetArray(fPath, wName, sName, Optional rng As String, Optional EDP As String) As Variant

    ' Open workbook

    Dim sfullname As String

    Dim wb As Workbook

    Dim ws As Worksheet

    Dim wsrng As Range

    Dim letter As String

    Dim lastrow As Long

    Dim icol As Long

    Set wb = Nothing

    If InStr(fPath, "/") Then

        sfullname = fPath

        Workbooks.Open sfullname, UpdateLinks:=False, ReadOnly:=True

        Set wb = Workbooks(wName)

        Set ws = Worksheets(sName)

        wb.Activate

        ws.Activate

        wName = ActiveWorkbook.name

        sName = ActiveSheet.name

        rng = findrange(wb, ws, rng)

        Set wsrng = wb.Worksheets(sName).Range(rng)

        GoTo sharepointopen

        Else

        sfullname = fPath & "\" & wName

    End If



    If IsFileOpen(sfullname) Then

        Set wb = Workbooks(wName)

        wb.Activate

        Set ws = Worksheets(sName)

        wb.Activate

        ws.Activate

        rng = findrange(wb, ws, rng)

        Set wsrng = wb.Worksheets(sName).Range(rng)

        Else

        Workbooks.Open sfullname, UpdateLinks:=False, ReadOnly:=True

        Set wb = Workbooks(wName)

        Set ws = Worksheets(sName)

        wb.Activate

        ws.Activate



        rng = findrange(wb, ws, rng)

        Set wsrng = wb.Worksheets(sName).Range(rng)

    End If

    sharepointopen:

    ' Create and allocate new array



    Dim Arr() As Variant

    Dim fixarr() As Variant



    Arr = wsrng.value



    If EDP <> "" Then

        For x = 1 To UBound(Arr)

            If Arr(x, 15) = EDP Then r = r + 1

        Next x



        ReDim fixarr(1 To r, 1 To wsrng.Columns.count)

        r = 1

        For y = 1 To UBound(Arr)

            If EDP = Arr(y, 15) Then



        For z = 1 To UBound(Arr, 2)

        fixarr(r, z) = Arr(y, z)

        Next z

        r = r + 1

        End If

        Next y

        GetArray = fixarr

        Else

        GetArray = Arr

    End If
End Function

Function findrange(wb As Workbook, ws As Worksheet, rng As String)

    Dim RHS As String
    Dim letter As String
    wName = wb.name
    sName = ws.name
    With ActiveWorkbook.ActiveSheet
    If .FilterMode Then .ShowAllData
    End With
    If rng <> "" Then
    RHS = Right(rng, 2)
    If HasNumber(RHS) = True Then
        findrange = rng
        Else
        letter = Left(rng, 1)
        icol = Letter2Number(letter)
        lastrow = Workbooks(wName).Worksheets(sName).Cells(Rows.count, icol).End(xlUp).Row
        If lastrow < 10 Then icol = icol + 1
            lastrow = Workbooks(wName).Worksheets(sName).Cells(Rows.count, icol).End(xlUp).Row
            findrange = rng & lastrow
        End If
    End If

    If rng = "" Then findrange = Workbooks(wName).Worksheets(sName).UsedRange.Address
    End Function

Function Letter2Number(letter As String)

Dim ColumnNumber As Long
Dim ColumnLetter As String

If letter = "" Then letter = "A"

'Input Column Letter
ColumnLetter = letter

'Convert To Column Number
ColumnNumber = Range(ColumnLetter & 1).Column

Letter2Number = ColumnNumber
End Function