Copy data from the workbook which opened by other user

[intex]

Hi guys,

Purpose of this code is to retrieve the data from closed workbook and consolidate everything in one report.

Today at work an issue did appear:
Problem was that if the file is opened by other user and i'm trying to retrieve data from this workbook the error comes in saying the sheet range is not defined correctly. When i attempting to retrieve data the file is opened read only mode, maybe this is the issue? But when the file is closed and not used by other users everything works fine.

Would somebody be so kind and help me to avoid this problem. Please see my current code below.

Regards

 Sub RoundedRectangle2_Click()

Dim strPath As String
Dim strPath1 As String
Dim strPath2 As String
Dim strPath3 As String
Dim strPath4 As String
Dim strPath5 As String
Dim strPath6 As String

    strPath = "C:\Users\URRaguckis\Desktop"
    GetData strPath & "\QC DATA 2012 - 2020..xlsm", "DataBase", "A2:X300000", Sheets("Data Support").Range("B3"), False, False
    
    strPath1 = "S:\CLUB ASSEMBLY QC\2. Incoming Inspection UK and Helmond"
    GetData strPath1 & "\Incoming Inspection Warehouse UK 2013 -.xlsm", "Data Collection", "D6:CA10000", Sheets("Data Support").Range("AD3"), False, False
    
    strPath2 = "S:\CLUB ASSEMBLY QC\1. UK"
    GetData strPath2 & "\Incoming Inspection 2013 -.xlsm", "Data Collection", "D6:CA10000", Sheets("Data Support").Range("DC3"), False, False
    
    strPath3 = "S:\CLUB ASSEMBLY QC\1. UK"
    GetData strPath3 & "\QC DATA 2012 - 2020 Ball Print Only..xlsm", "Data Collection", "D5:S30000", Sheets("Data Support").Range("GA3"), False, False
    
    strPath4 = "S:\CLUB ASSEMBLY QC\1. UK"
    GetData strPath4 & "\QC DATA 2012 - 2020 Cresting Only..xlsm", "Data Collection", "A2:R30000", Sheets("Data Support").Range("GR3"), False, False
    
    strPath5 = "S:\CLUB ASSEMBLY QC\1. UK"
    GetData strPath5 & "\Calibration Checks.xlsm", "Calibration Checks", "B11:BZ2649", Sheets("Data Support").Range("HK3"), False, False
    
    strPath6 = "S:\Rick\QC\Issue Tracker"
    GetData strPath6 & "\Issue tracker rev..xlsm", "Sheet1", "B10:L1000", Sheets("Data Support").Range("KK3"), False, False
    
    End Sub

and the code in module is:

Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub