I need to run a VBScript that can dynamically set a SQL Server connection string, taking server name and database name from Excel cells, and refresh tables in all worksheets of the file.
I currently have this script against a 'Refresh' button on the 'Setup' sheet (from where it takes the server and database names):
Sub Refresh_Click()
Dim Sh As Worksheet
Dim sServer As String
Dim sDatabase As String
Dim sTableName As String
Dim vDestinationRg As Variant
Dim sQuery(1 To 24) As String
Dim vQueryArray As Variant
Dim i As Integer
Dim j As Integer
Dim isSplit As Boolean
Dim sUsername As String
Dim sPassword As String
Set Sh = ActiveSheet
j = 1
isSplit = True
vQueryArray = Application.Transpose(Sh.Range("U1:U10"))
For i = LBound(vQueryArray) To UBound(vQueryArray)
If vQueryArray(i) <> "" Then
isSplit = False
sQuery(j) = sQuery(j) & Trim(vQueryArray(i)) & vbCrLf
ElseIf Not isSplit Then
isSplit = True
j = j + 1
End If
Next i
sServer = Sheets("Setup").Range("F5").Value
sDatabase = Sheets("Setup").Range("F7").Value
vDestinationRg = Array("$H$12")
sUsername = "username"
sPassword = "********"
For i = LBound(sQuery) To UBound(sQuery)
If sQuery(i) = "" Then Exit Sub
sTableName = "Result_Table_" & Replace(Replace(Sh.Name, " ", ""), "-", "") & "_" & i
On Error Resume Next
Sh.ListObjects(sTableName).Delete
On Error GoTo 0
With Sh.ListObjects.Add(SourceType:=0, Source:=Array( _
"OLEDB;Provider=SQLOLEDB.1;User Id=" & sUsername & "; Password=" & sPassword & ";Data Source=" & sServer & ";Initial Catalog=" & sDatabase & ""), Destination:=Sh.Range(vDestinationRg(i - 1))).QueryTable
.CommandText = sQuery(i)
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = sTableName
.Refresh BackgroundQuery:=False
End With
Next
End Sub
I have a select query written in cell "U1" of the 'Setup' sheet and it creates and populates the table into the destination range starting from "H12".
But instead of placing the query on the 'Setup' sheet I want to write queries on different worksheets which would populate tables in the respective worksheets, with only this one Refresh button click on the Setup sheet.
How can I do this?
I have been told it can be achieved without writing VBScript also, but no luck there! I tried adding SQL server connections to the workbook, but can't make it dynamic from there.
Related
I would like to import a text file into Excel filtering just what I want through a VBA macro. The amount of data is large so I use efficently the Power queries. I have a list of several things to filter and process differently and this list could change. So for each "feature" to filter I reload the query in a new sheet.
If the filter makes the query empty I get an error from the Power Query that I am not able to skip with:
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Debugging I see that the error comes out between the query creation and the paste to the sheet, see (*) in the code below.
Does somebody know if there is a way to have the number of records into the query in order to be able to use an if statement and skip the paste phase?
The only other idea that I have is to write automatically a row for each feature into the txt file to filter but it is not an elegant method
A thing that I do not understand is that the problem appear using a function, see below, but not using directly a macro.
When I use the function the error shown does not appear always but in any case the code finish the function but the main macro stops.
test.txt
946737295 9CE78280 FF 1 5 FF FF FF FF FF
946737295 9CE78280 C0 FF 0 0 0 0 FF FF
946737295 9CE68082 C0 4 0 FF FF FF FF FF
and the macro is:
Function readTxt(input_path As String, Pgn As String, B2 As String, B3 As String) As Boolean
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Conn As WorkbookConnection
Dim mFormula As String
Dim query As WorkbookQuery
Set Wb = ActiveWorkbook
Set Ws = Wb.ActiveSheet
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mFormula = "let " & _
"Source = Csv.Document(File.Contents(""" & input_path & """),[Delimiter=""#(tab)"", Columns=10, Encoding=65001, QuoteStyle=QuoteStyle.Csv])," & _
"#""Step1"" = Table.SelectRows(Source, each Text.Contains([Column2], """ & Pgn & """) and [Column5] = """ & B3 & """ and [Column4] = """ & B2 & """)," & _
"#""Step2"" = Table.RemoveColumns(Step1,{""Column2"", ""Column3"", ""Column4"", ""Column5"", ""Column9"", ""Column10""})" & _
"in #""Step2"""
Set query = Wb.Queries.Add("test_7", mFormula)
With Ws.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & "test_7" & ";Extended Properties=""""", Destination:=Ws.Range("A3"), XlListObjectHasHeaders:=xlYes).QueryTable
'.ListObject.TotalsRowRange
.CommandType = xlCmdSql
.AdjustColumnWidth = False
.ListObject.Name = "test"
.CommandText = "SELECT * FROM [" & "test_7" & "]"
.Refresh BackgroundQuery:=False
End With
If Err.Number <> 0 Then
Err.Clear
End If
query.Delete
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
readTxt = True 'output
On Error GoTo 0
End Function
Sub readTxt()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Conn As WorkbookConnection
Dim mFormula As String
Dim query As WorkbookQuery
Set Wb = ActiveWorkbook
Dim i As Integer
Dim C3 As String
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
C3 = "F2"
For i = 1 To 2
If i = 2 Then
C3 = "FF"
Sheets.Add After:=ActiveSheet
End If
Set Ws = Wb.ActiveSheet
mFormula = "let " & _
"Source = Csv.Document(File.Contents(""C:\test.txt""),[Delimiter=""#(tab)"", Encoding=65001, QuoteStyle=QuoteStyle.Csv])," & _
"#""Step1"" = Table.SelectRows(Source, each Text.Contains([Column2], ""E7"") and [Column3] = """ & C3 & """)" & _
"in #""Step1"""
Set query = Wb.Queries.Add("Test_text", mFormula)
' (*) THE ERROR OF POWER QUERY APPEARS HERE
With Ws.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & "Test_text" & ";Extended Properties=""""", Destination:=Ws.Range("A3"), XlListObjectHasHeaders:=xlYes).QueryTable
.CommandType = xlCmdSql
.AdjustColumnWidth = False
.ListObject.Name = "test"
.CommandText = "SELECT * FROM [" & "Test_text" & "]"
.Refresh BackgroundQuery:=False
End With
query.Delete
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
Thanks,
Ruggero
You can check if a step (table) has some specific columns using this code:
let Source = Csv.Document(File.Contents("C:\temp\test.txt"),[Delimiter=";", Encoding=65001, QuoteStyle=QuoteStyle.Csv]),
#"Step1" = Table.SelectRows(Source, each Text.Contains([Column2], "E7") and [Column3] = "F1"),
result_error = "Some error",
check_columns = Table.HasColumns(#"Step1", {"Column2", "Column3"}),
result = if check_columns = true then #"Step1" else result_error
in result
See the check_columns step and the conditional result
I need to import an xls file from the web address https://docs.misoenergy.org/marketreports/YYYYMMDD_sr_nd_is.xls where YYYYMMDD is inputed by the user on another worksheet in the same workbook. In the code below nsiday = 20190316 - 1. I don't know how to actually paste the data in the worksheet I want. I am trying to adapt code that grabs a csv file so that it works for the xls file (https://docs.misoenergy.org/marketreports/YYYYMMDD_rt_lmp_final.csv). I hope that makes sense and thank you all for reading/helping! Note: I haven't included the full csv code I'm trying to adapt.
Option Explicit
Sub NSI()
Dim xday As String
Dim todaystamp As String
Dim nsiday As String
Dim MISORTSht As Worksheet
Dim Selection As Range
Set MISORTSht = Sheet3
MISORTSht.Cells.ClearContents
If MISORTSht.QueryTables.Count > 0 Then
MISORTSht.QueryTables(1).Delete
End If
Dim web As Object
Set web = CreateObject("Microsoft.XMLHTTP")
todaystamp = Format(Sheet1.Cells(6, 1).Value, "yyyymmdd")
xday = Format(Sheet1.Cells(1, 1).Value, "yyyymmdd")
'xday is user defined
nsiday = xday - 1
start:
web.Open "GET", "https://docs.misoenergy.org/marketreports/" & nsiday & "_sr_nd_is" & ".xls", False
web.send
If web.Status = "200" Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With MISORTSht.QueryTables.Add(Connection:="URL;https://docs.misoenergy.org/marketreports/" & nsiday & "_sr_nd_is" & ".xls" _
, Destination:=MISORTSht.Range("A1"))
.Name = "NSI_MISO"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Disregarding the use of QueryTable, you can open online files directly from Excel. Below is an example of how to generate the URL based on a date input and opens it from Excel.
Option Explicit
Private Const DATE_FMT As String = "yyyymmdd"
Private Const BASE_URL As String = "https://docs.misoenergy.org/marketreports/"
Private Const POSTFIX1 As String = "_sr_nd_is.xls"
Private Const POSTFIX2 As String = "_rt_lmp_final.csv"
Sub Main()
Dim dDataDate As Date, dToday As Date, oWB As Workbook
dToday = CDate(ThisWorkbook.Sheets(1).Cells(6, 1).Value) ' Not sure what to do with this
dDataDate = CDate(ThisWorkbook.Sheets(1).Cells(1, 1).Value) - 1 ' 1 day before it
Set oWB = GetOnlineFile(CreateURL1(dDataDate))
If Not oWB Is Nothing Then
' Do whatever you need with the opened file
oWB.Close
Set oWB = Nothing
End If
End Sub
Private Function GetOnlineFile(URL As String) As Workbook
On Error Resume Next
Set GetOnlineFile = Workbooks.Open(URL)
End Function
Private Function CreateURL1(DataDate As Date) As String
CreateURL1 = BASE_URL & Format(DataDate, DATE_FMT) & POSTFIX1
End Function
Private Function CreateURL2(DataDate As Date) As String
CreateURL2 = BASE_URL & Format(DataDate, DATE_FMT) & POSTFIX2
End Function
I have to import a number of text files into excel and add each text file to a new sheet. The number of lines on some files are in excess of 350,000. Loops take so long that it's not really user friendly. I've tried using this to read the data in quickly
Dim arrLines() As String
Dim lineValue As String
lineValue = ts.ReadAll
DoEvents
arrLines() = Split(lineValue, vbCrLf)
Dim Destination As Range
Set Destination = Worksheets(WorksheetName).Range("A2")
Set Destination = Destination.Resize(UBound(arrLines), 1)
Destination.Value = Application.Transpose(arrLines)
but this results in every value AFTER line 41243 simply having a value of "#N/A". I was thinking to use a Application.Index to split up the array into smaller arrays, but you need to give the index function an array of lines that you want to compose the new array, and that would mean creating a loop to run through the numbers 1-41000, then 41001-82000, etc. At the point i'm doing a loop to create the arrays it's not really faster. looping through the file line by line is similarly too slow. What's a good way of reading in a such a large number of lines without ending up with the missing values?
You could use and automate the 'Data' -> 'From Text/CSV' wizard of Excel.
Using the Macro recorder you end up with this, which should be a good start:
ActiveWorkbook.Queries.Add Name:="MyFile", Formula:="let" & Chr(13) & "" & Chr(10) & " Source = Table.FromColumns({Lines.FromBinary(File.Contents(""C:\Path\MyFile.txt""), null, null, 1252)})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " Source"
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""MyFile"";Extended Properties=""""", Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [MyFile]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "MyFile"
.Refresh BackgroundQuery:=False
End With
Copy Text Files to Excel
Credits to simple-solution for suggesting (in the comments) to open the text files with Workbooks.Open.
The Code
Sub CopyTextFilesToExcel()
' Search Folder Path
Const cStrPath As String _
= "D:\Excel\MyDocuments\StackOverflow\"
Const cStrExt As String = "*.txt" ' File Extension
Const cFolderPicker As Boolean = False ' True to enable FolderPicker
Dim wb As Workbook ' Current File
Dim strPath As String ' Path of Search Folder (Incl. "\" at the end.)
Dim strFileName As String ' Current File Name
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo ProcedureExit
' Determine Search Path ("\" Issue)
If cFolderPicker Then
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
strPath = .SelectedItems(1) & "\"
End With
Else
If Right(cStrPath, 1) <> "\" Then
strPath = cStrPath & "\"
Else
strPath = cStrPath
End If
End If
' Determine first Current File Name.
strFileName = Dir(strPath & cStrExt)
With ThisWorkbook ' Target Workbook
' Loop through files in folder.
Do While strFileName <> ""
' Create a reference to the Current File.
Set wb = Workbooks.Open(cStrPath & strFileName)
' Copy first worksheet of Current File after the last sheet
' (.Sheets.Count) in Target Workbook.
wb.Worksheets(1).Copy After:=.Worksheets(.Sheets.Count)
' Close Current File without saving changes (False).
wb.Close False
' Find next File(name).
strFileName = Dir()
Loop
End With
MsgBox "All files copied!"
ProcedureExit:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Mathieu Guindon had EXACTLY the solution I was hoping for. Eliminating the transpose has solved the issue with the #N/A values. Thank you!
Edit:
The code just loops the arrayed data a second time into a two dimensional array and then posts it to the range without the transpose effect. It's a little slower than the old way (taking about two minutes or so longer), but it's still pretty fast and produces the results I want. Code is as follows:
lineValue = ts.ReadAll
DoEvents
arrLines() = Split(lineValue, vbCrLf)
Dim arrBetween() As Variant
ReDim arrBetween(UBound(arrLines), 0)
LoopLength = UBound(arrLines) - 1
For i = 0 To LoopLength
arrBetween(i, 0) = arrLines(i)
DoEvents
If i Mod 2500 = 0 Or i = LoopLength Then
Application.StatusBar = "Importing " & WorksheetName & " " & (i) & " ."
End If
Next i
Dim Destination As Range
Set Destination = Worksheets(WorksheetName).Range("A2:A" & UBound(arrLines))
Destination.Value = arrBetween
I'm having some problems when I try to import a Query from Access to Excel.
Some days ago I programmed a code (with some help of Google haha) to import a Table from Access to Excel:
Sub importQuery(DBFullName As String, data_sht As Worksheet)
Dim cn As Object, rs As Object
Dim i As Integer
Dim TargetRange As Range
Dim rows As Long, cols As Long
Dim dataEmpty As Boolean
Dim lastColString As String
data_sht.Activate
Application.ScreenUpdating = False
Set TargetRange = data_sht.Range("A1")
Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Ace.OLEDB.12.0; Data Source=" & DBFullName & ";" 'the Access file is .accdb
Set rs = CreateObject("ADODB.Recordset")
rs.Open "SELECT * FROM C_Paso2_SM_Cuplas", cn, , , adCmdUnspecified
cols = rs.Fields.Count
rows = data_sht.Range("A" & data_sht.rows.Count).End(xlUp).Row
' Copy titles of the Access Query
For i = 0 To (cols - 1)
TargetRange.Offset(0, i).Value = rs.Fields(i).Name
Next
' Copy data
TargetRange.Offset(1, 0).CopyFromRecordset rs
End Sub
That code works but when I do this:
rs.Open "SELECT * FROM C_Paso2_SM_Cuplas", cn, , , adCmdUnspecified
I'm importing another Query called C_Paso1_SM_Cuplas, from the same file. What can I do? Why am I importing C_Paso1_SM_Cuplas when I say C_Paso2_SM_Cuplas? Is there other possibility to import an Access Query to Excel?
Try this DAO solution.
Sub ImportFromAccessToExcel()
Dim db1 As Database
Dim db2 As Database
Dim recSet As Recordset
Dim strConnect As String
Set db1 = OpenDatabase("C:\Database1.mdb")
strConnect = db1.QueryDefs("Query3").Connect _
& "DSN=myDsn;USERNAME=myID;PWD=myPassword"
Set db2 = OpenDatabase("", False, False, strConnect)
db2.Close
Set db2 = Nothing
Set recSet = db1.OpenRecordset("Query3")
With ActiveSheet.QueryTables.Add(Connection:=recSet, Destination:=Range("$A$4"))
.Name = "Connection"
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
recSet.Close
db1.Close
Set recSet = Nothing
Set db1 = Nothing
End Sub
This is my current VBA code:
Option Explicit
Private Function LoopThroughFolder(RootFolder As String, CsvFolder As String, Status As String)
Dim folder, StrFile As String
Dim wks As Worksheet
folder = RootFolder & "\" & CsvFolder & "\" & Status
StrFile = Dir(folder & "\*.csv")
Do While Len(StrFile) > 0
Set wks = Worksheets(CsvFolder & Status)
ImportCsv folder & "\" & StrFile, wks
StrFile = Dir
Loop
'Debug.Print RootFolder & "\" & CsvFolder & "\" & Status & " >>> OK!"
End Function
Private Function ImportCsv(CsvFile As String, wks As Worksheet)
Dim row&, col As Integer
'Debug.Print CsvFile
row = wks.Cells(Rows.Count, 1).End(xlUp).row
With wks.QueryTables _
.Add(Connection:="TEXT;" & CsvFile, Destination:=wks.Cells(row + 1, 1))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Function
Public Sub ImportFolderCsv()
Dim RootFolder As String
RootFolder = "C:\Users\chinkai\Desktop\dims investigate"
Dim CsvFolders(1 To 2) As String
CsvFolders(1) = "csvVeh"
CsvFolders(2) = "csvCust"
Dim Statuses(1 To 2) As String
Statuses(1) = "FAIL"
Statuses(2) = "PASS"
Dim i, j As Integer
Dim folder As String
Dim ws As Worksheet
For i = 1 To 1
For j = 1 To 2
Sheets.Add.Name = CsvFolders(i) & Statuses(j)
LoopThroughFolder RootFolder, CsvFolders(i), Statuses(j)
Next j
Next i
End Sub
When I open my worksheets to view, the data appears in the form of an inverted triangle. Data from the first CSV goes into the top right corner, data from the second CSV goes below but to the left, so on and so forth, until the last CSV where data appears in the bottom left corner.
What my data looks like:
New to Excel VBA, so most of the code here are copy-pasta. I tried to tweak what I can but now I am not sure where I have gone wrong. Advice/feedback appreciated, thank you!
Edit: made some changes as suggested. Updated my code above and also provided a screen capture of this weird display...
I have played a bit with your code, but I could not replicate the "reversed triangle thing". However, just to make you started somewhere:
Replace the ActiveSheet with a reference of the worksheet, that you should pass as a parameter to the ImportCsv function:
Private Function ImportCsv(CsvFile As String, wks As Worksheet)
Dim row&, col As Long
Debug.Print CsvFile
row = wks.Cells(Rows.Count, 1).End(xlUp).row
With wks.QueryTables _
.Add(Connection:="TEXT;" & CsvFile, Destination:=wks.Cells(row + 1, 1))
And you take the wks like this from the Status string:
Private Function LoopThroughFolder(RootFolder As String, CsvFolder As String, Status As String)
Dim folder, StrFile As String
Dim wks As Worksheet
folder = RootFolder & "\" & CsvFolder & "\" & Status
StrFile = Dir(folder & "\*.csv")
Do While Len(StrFile) > 0
Set wks = Worksheets("csvVeh" & Status)
Two more important points:
write Option Explicit on the top of your module and try to declare all variables. Then go to Debug>Compile on the VBEditor ribbon and declare what is not declared.
as #Peh mentioned in the comments if you declare like this in C++ Dim a, b as Integer, then a and b are Integers. In VBA only b is declared as an Integer, a is a Variant. You should declare Dim a As Integer, b as Integer
Why Use Integer Instead of Long?