Hi Rick,

Revised Sub is

Code:
Sub TransferData(strInputFileFullName As String, strOutPutFileFullName As String, strInputSheetName As String)
    
    Dim adoConnection   As New ADODB.Connection
    Dim adoRcdSource    As New ADODB.Recordset
    Dim Provider        As String
    Dim ExtProperties   As String
    Dim strFileExt      As String
    
    
    If Len(Dir(strInputFileFullName)) = 0 Then
        MsgBox "Input file does not exist"
        Exit Sub
    End If
    strFileExt = Mid(strOutPutFileFullName, InStrRev(strOutPutFileFullName, ".", -1, vbTextCompare), Len(strOutPutFileFullName))
    If strFileExt = ".xlsx" Then
        ExtProperties = "Excel 12.0 XML"
    Else
        ExtProperties = "EXCEL 8.0"
    End If
    If CDbl(Application.Version) > 11 Then
      Provider = "Microsoft.ACE.OLEDB.12.0"
    Else
       Provider = "Microsoft.JET.OLEDB.4.0"
    End If
    
    adoConnection.Open "Provider=" & Provider & ";Data Source= " & strOutPutFileFullName & ";Extended Properties=""" & ExtProperties & ";HDR=YES"";"
    adoRcdSource.Open "Select * into [" & strInputSheetName & "] From [" & strInputSheetName & "$] IN '" & strInputFileFullName & "'[" & ExtProperties & ";HDR=YES;]", adoConnection
       
    
    adoConnection.Close
    
    Set adoRcdSource = Nothing
    Set adoConnection = Nothing
    
End Sub