How to retrieve data from other Excel using VBA and SQL? - sql

Question

I have a problem with my code. I tried retrieving data from other Excel file. My code works but I received full data in one cell (A1). I'm sorry but I'm just beginner, believe that's the problem related to output, but I'm not find out why:
Sub RefreshData()
'Refresh data
Dim CreateNew As Object
Dim RunSELECT As Object
Dim Data As String
Dim SQL As String
FolderPath = ActiveWorkbook.path
path = Left(FolderPath, InStrRev(FolderPath, "\") - 1)
Set CreateNew = CreateObject("ADODB.Connection")
With CreateNew
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & path & "\Task1.xlsm; Extended Properties=Excel 12.0 Xml;HDR=YES;IMEX=1;CorruptLoad=xlRepairFile"
.Open
End With
'Run SQL
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
Do
output = output & RunSELECT(0) & ";" & RunSELECT(1) & ";" & RunSELECT(2) & vbNewLine
Debug.Print RunSELECT(0); ";" & RunSELECT(1) & ";" & RunSELECT(2)
RunSELECT.Movenext
Loop Until RunSELECT.EOF
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing
End Sub

Answer 1

No need to wrap recordset values wtih semicolon delimiters using a Do loop. Simply use Range.CopyFromRecordset:
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
ThisWorkbook.Worksheets("Dic").Range("A1").CopyFromRecordset RunSELECT
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing

Answer 2

ADOdb to Retrieve Data From Another Workbook (Without Opening It)
While playing around with Parfait's solution combined with a few posts, I came up with the function copySheetADOdb.
Adjust the constants under Source and Target in testCopySheetADOdb to test it.
The Code
Option Explicit
Sub testCopySheetADOdb()
' Initialize error handling.
Const ProcName = "testCopySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Source
Const Path As String = "F:\Test"
Const FileName As String = "Test.xlsx"
' Sheet Name ('SheetName') is case-insensitive i.e. 'A = a'.
Const SheetName As String = "Sheet1"
' Target
Const tgtName As String = "Sheet1"
Const tgtCell As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
' Define FilePath.
Dim FilePath As String
FilePath = Path & Application.PathSeparator & FileName
' Define Target Range.
Dim rng As Range
Set rng = wb.Worksheets(tgtName).Range(tgtCell)
' Test Result.
Dim Result As Boolean
Result = copySheetADODb(rng, FilePath, SheetName)
' Of course you can do all the above in one line:
'Result = copySheetADODB(Thisworkbook.Worksheets("Sheet1").Range("A1"), _
"C:\Test\Test.xlsx", "Sheet1")
' Inform user.
If Result Then
MsgBox "Worksheet successfully copied.", vbInformation, "Success"
Else
MsgBox "Worksheet not copied.", vbExclamation, "Failure"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Function copySheetADOdb(TargetCellRange As Range, _
ByVal SourceFilePath As String, _
Optional ByVal SourceSheetName As String = "Sheet1") _
As Boolean
' Initialize error handling.
Const ProcName = "copySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Test Target Cell Range ('TargetCellRange').
If TargetCellRange Is Nothing Then
GoTo NoTargetCellRange
End If
If TargetCellRange.Rows.Count > 1 Or TargetCellRange.Columns.Count > 1 Then
GoTo OneCellOnly
End If
'
' Define SQL Generic String.
Const sqlGeneric As String = "SELECT * FROM [SheetName$]"
Dim conn As Object
Set conn = CreateObject("ADODB.Connection")
Dim strErr As String
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
' If you need the headers, HDR=NO means there are no headers
' (not: do not retrieve headers) so the complete data will be retrieved.
.ConnectionString = "Data Source='" _
& SourceFilePath _
& "';" _
& "Extended Properties='" _
& "Excel 12.0 Xml;" _
& "HDR=NO;" _
& "IMEX=1;" _
& "CorruptLoad=xlRepairFile" _
& "';"
On Error GoTo connOpenError
.Open
On Error GoTo clearError
' Run SQL.
Dim SQL As String
' Replace 'SheetName' in SQL Generic String
' with the actual sheet name ('SourceSheetName').
SQL = Replace(sqlGeneric, "SheetName", SourceSheetName)
Dim rs As Object
On Error GoTo connExecuteError
Set rs = .Execute(SQL)
On Error GoTo clearError
If Not TargetCellRange Is Nothing Then
' Copy sheet.
If Not rs.EOF Then
TargetCellRange.CopyFromRecordset rs
' Write result.
copySheetADOdb = True
Else
GoTo NoRecords
End If
End If
NoRecordsExit:
rs.Close
connExecuteExit:
.Close
End With
ProcExit:
Set rs = Nothing
connOpenExit:
Set conn = Nothing
Exit Function
NoTargetCellRange:
Debug.Print "'" & ProcName & "': " & "No Target Cell Range ('Nothing')."
GoTo ProcExit
OneCellOnly:
Debug.Print "'" & ProcName & "': " _
& "Target Cell Range has to be one cell range only."
GoTo ProcExit
NoRecords:
Debug.Print "'" & ProcName & "': No records found."
GoTo NoRecordsExit
connOpenError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceFilePath & "' is not a valid path"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connOpenExit
End If
Else
GoTo clearError
End If
connExecuteError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceSheetName & "' is not a valid name"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connExecuteExit
End If
Else
GoTo clearError
End If
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function

Answer 3

You have problem in this code:
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
you are yourself asking to save the output to A1 Cell.
I would suggest you use for or while loop to enter the data in cells according to your need.