Function SQL(fileName As String, kolumny As String) As Variant Application.Volatile Dim path As String Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim currAddress As String Dim varHdr, varDat, contentOut As Variant Dim nc, nr, i, j As Long path = ThisWorkbook.path & "\Data\" SQL = Null 'currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False) strFile = ThisWorkbook.FullName strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & path & ";" & _ "Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""" Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") rs.CursorLocation = adUseClient ' required to return the number of rows correctly cn.Open strCon strSQL = "select " & kolumny & " from " & fileName rs.Open strSQL, cn 'Check if recordset is empty If rs.EOF Then MsgBox "Function does not return any values" SQL = "" Exit Function End If ' Process Column Headings nc = rs.Fields.Count ReDim varHdr(nc - 1, 0) For i = 0 To rs.Fields.Count - 1 varHdr(i, 0) = rs.Fields(i).Name Next ' Get Rows from the Recordset nr = rs.RecordCount varDat = rs.GetRows ' Combing Header and Data and Transpose ReDim contentOut(0 To nr, 0 To nc - 1) For i = 0 To nc - 1 contentOut(0, i) = varHdr(i, 0) Next For i = 1 To nr For j = 0 To nc - 1 contentOut(i, j) = varDat(j, i - 1) Next Next ' Optional solution: Write Output Array to Sheet2 ' With Sheet2 ' .Cells.Clear ' .Range("A1").Resize(nr, nc) = contentOut ' End With 'Figure out size of calling range which will receive the output array Dim nRow As Long: nRow = Application.Caller.Rows.Count Dim nCol As Long: nCol = Application.Caller.Columns.Count 'Error if calling range too small If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then 'Popup message 'MsgBox "your range is too small." ' or return #VALUE! error SQL = "Too small range" 'CVErr(xlValue) ' or both or whatever else you want there to happen Exit Function End If 'Initialise output array to match size of calling range Dim varOut As Variant ReDim varOut(1 To nRow, 1 To nCol) 'And fill it with some background value Dim iRow As Long Dim iCol As Long For iRow = 1 To nRow For iCol = 1 To nCol varOut(iRow, iCol) = "" ' or "funny bear", or whatever Next Next 'Put content in output array and return For iRow = 0 To UBound(contentOut, 1) For iCol = 0 To UBound(contentOut, 2) varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol) Next Next SQL = varOut 'Cleanup Erase contentOut Erase varHdr Erase varDat rs.Close Set rs = Nothing Set cn = Nothing End Function
czwartek, 28 maja 2015
SQL w Excelu: Odpytaj plik tekstowy za pomocą funkcji Excela
Drobna przeróbka mojego poprzedniego makra w celu czytania i kwerendy plików tekstowych w Excelu za pomocą funkcji:
Subskrybuj:
Komentarze do posta (Atom)
Brak komentarzy:
Prześlij komentarz