Can anyone please help me to figure out what is wrong with below VBScripting and how should I correct it?
It meant to
Open excel -- works
Refresh all data -- works
Remove external connection -- Dont work
Save as new file without any external connection -- Dont work due to 3rd step otherwise it does
Solution:
Set oExcel = CreateObject("Excel.Application")
oExcel.Application.Visible = True
oExcel.DisplayAlerts = False
oExcel.AskToUpdateLinks = False
oExcel.AlertBeforeOverwriting = False
Set oWorkbook = oExcel.Workbooks.Open("file path.xlsx")
oWorkbook.RefreshAll
Do While oExcel.ActiveWorkbook.Connections.Count > 0
oExcel.ActiveWorkbook.Connections.Item(oExcel.ActiveWorkbook.Connections.Count).Delete
Loop
oExcel.Activeworkbook.SaveAs "NewFileName_"& _
MyDateFormat &".xlsx"
oExcel.Activeworkbook.Close
oExcel.Quit
WScript.Quit
Please, try the next way:
Dim oExcel, oWorkbook
Set oExcel = CreateObject("Excel.Application")
oExcel.Application.Visible = True
oExcel.DisplayAlerts = False
oExcel.AskToUpdateLinks = False
oExcel.AlertBeforeOverwriting = False
Set oWorkbook = oExcel.Workbooks.Open("file path.xlsx")
oWorkbook.RefreshAll
'new approach to also delete the named range from Name Manager
Dim strAddr, N
strAddr = Split(oWorkbook.Connections("connection name").Ranges(1).Address(,,,True), "]")(1)
oWorkbook.Connections("connection name").Delete
For Each N In oWorkbook.Names
If Replace(strAddr, "'", "") = Replace(Mid(N.RefersTo, 2), "'", "") Then
N.Delete
End If
Next
oWorkbook.SaveAs "NewFileName_" & MyDateFormat & ".xlsx"
oWorkbook.Close
oExcel.Quit
Related
I've written a VB Script to go through a folder, extract a record number from the filenames inside, query the corresponding zone for those record numbers, and rename/move the files as appropriate.
First I make a recordset of the files inside (rsFiles), and I build a SQL String from those record numbers as an inlist to query the corresponding zones into a second recordset (rsZones). Then I move through rsZones and write the appropriate zone back to rsFiles.
My code works with a small number of files (I've tested and gotten reliable results up to 200) but I need to process several thousand at a time... If I throw too many files at it, I get error 80040E14 "Could not find prepared statement with handle -1." at the line that does rsZones.MoveFirst.
I think this means rsZones doesn't have any records, but shouldn't that mean rsZones.EOF would resolve to TRUE? Also, I have the ADODB Command timeout set at 0, so why am I not getting records on a larger inlist?
Code extract below. Any help/ideas would be appreciate. Thanks!!
Const sSourceDir = "C:\MyDir\"
Set re = New RegExp
re.Global = False
Set rsFiles = CreateObject("ADOR.Recordset")
rsFiles.Fields.Append "File", adVarChar, MaxCharacters
rsFiles.Fields.Append "Record_Number", adVarChar, 10
rsFiles.Fields.Append "Zone", adVarChar, 2
rsFiles.Open
re.Pattern = "(\d{1,})_\d{1,}_[IPG]\S*.pdf"
Set oFolder = oFSO.GetFolder(sSourceDir)
Set oFiles = oFolder.Files
If oFiles.Count > 0 Then
For each oFile in oFiles
Set reMatches = re.Execute(oFile.Name)
If reMatches.Count > 0 Then
sRecordNumber = reMatches(0).subMatches(0)
sInlist = sInlist & "'" & sRecordNumber & "',"
Else
sRecordNumber = ""
End If
rsFiles.AddNew
rsFiles("File") = oFile.Name
rsFiles("Record_Number") = sRecordNumber
Next
End If
If sInlist = "" Then
MsgBox "No files matching record number pattern"
wScript.Quit
End If
sInlist = Left(sInlist, Len(sInlist)-1)
Const sConn = "Provider=SQLOLEDB;SERVER=my\server;DATABASE=default_database;TRUSTED_CONNECTION=yes"
sSQL = "select tablea.record_number, tablea.zone from tablea where tablea.record_number in (" & sInlist & ")"
Set oConn = CreateObject("ADODB.Connection")
oConn.ConnectionTimeout = 0
oConn.Open sConn
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = oConn
.CommandText = sSQL
.CommandType = 1 'adCmdText
.CommandTimeout = 0
.Prepared = True
End With
set rsZones = CreateObject("ADODB.Recordset")
Set rsZones = cmd.Execute
If Not rsZones.EOF Then
rsZones.MoveFirst 'ERROR IS HERE
Do until rsZones.EOF
rsFiles.Filter = 0
rsFiles.Filter = "record_number = '" & rsZones(0) & "'"
rsFiles.MoveFirst
Do Until rsFiles.EOF
rsFiles("Zone") = rsZones("Zone")
rsFiles.MoveNext
Loop
rsZones.MoveNext
Loop
End If
rsZones.Close
So Ive been trying to read from a large access database and the table iam trying to read from contains nearly 20000 entries, all of which are needed in the combox. With some testing I have figured out that the program slows down the longer it runs. The first 5000 are added almost instantaneously, but the next 5000 increment increase exponentially. Over all it would take about 5 minutes to load the entire thing. Am i missing something that will make it more efficient? Ive attached the function iam using below. It is in Vb.net
Private Sub chkBoxPurchasedPart_CheckedChanged(sender As Object, e As EventArgs) Handles chkBoxPurchasedPart.CheckedChanged
If (chkBoxPurchasedPart.Checked) Then
chkBoxRawMaterial.Checked = False
chkBoxSkipMaterialSelection.Checked = False
MaterialButton.Enabled = True
comboxMaterial.Sorted = True
comboxMaterialHdn.Text = "AS SUPPLIED"
comboxMaterialHdn.Enabled = False
Dim cn As OleDbConnection
Dim cmd As OleDbCommand
Dim dr As OleDbDataReader
Dim oConnect, oQuery As String
oConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=Y:\eng\ENG_ACCESS_DATABASES\VisibPartAttributes.mdb"
oQuery = "SELECT * FROM VISIB_PARTMASTER_LOCAL WHERE PRODUCT_LINE LIKE '%PUR%' OR PRODUCT_LINE LIKE '%NOSTD%' AND PARTDESCR NOT LIKE '%OBSOLETE%'"
Try
cn.Open()
Catch ex As Exception
Finally
cn = New OleDbConnection(oConnect)
cn.Open()
End Try
cmd = New OleDbCommand(oQuery, cn)
dr = cmd.ExecuteReader
comboxMaterial.Items.Add("- - OTHER - -")
While dr.Read()
comboxMaterial.Items.Add(dr(0))
End While
dr.Close()
cn.Close()
Try
Dim s As Session = Session.GetSession()
Dim dispPart As Part = s.Parts.Display()
Dim c As NXOpen.Assemblies.Component = dispPart.ComponentAssembly.RootComponent
Dim children As NXOpen.Assemblies.Component() = c.GetChildren()
Dim childMaterial As String = Nothing
For Each child As NXOpen.Assemblies.Component In children
childMaterial = child.GetStringAttribute("STACKTECK_PARTN")
If (childMaterial.Length > 5 Or child.Name.StartsWith("PUR")) Then
comboxMaterial.Text = childMaterial
End If
Next
Catch ex As Exception
End Try
ElseIf (chkBoxPurchasedPart.Checked = False) Then
comboxMaterialHdn.Text = ""
comboxMaterialHdn.Enabled = True
txtBoxDiameter.Enabled = True
txtBoxRoundLength.Enabled = True
txtBoxInnerDiameter.Enabled = True
txtBoxLength.Enabled = True
txtBoxWidth.Enabled = True
txtBoxThickness.Enabled = True
MaterialButton.Enabled = False
txtBoxVisMaterial.Text = ""
txtBoxVisMaterialDescription.Text = ""
txtBoxEachQuantity.Text = ""
txtBoxTotalQuantity.Text = ""
txtBoxUnitOfMeasure.Text = ""
comboxMaterial.Sorted = False
comboxMaterial.Items.Clear()
comboxMaterial.Text = ""
End If
End Sub
For anyone in the future having a similar issue, the combobox wasnt the problem, the previous designer had the AutoCompleteMode set to suggest and append which slowed the entire process down. Disable it and your program should speed up.
I would only load the combo-box records after the first 3 or 4 characters have been entered. This should drastically reduce the number of records being returned, and a still allow the autocomplete to work.
This thread has code to assist you : get 65K records only listed in combo box from a table of 155K records
I would like to ask for some help, here's the context: I'm using an Excel Workbook that is connected to my SQL Server with ODBC, so the user can use it to make some queries using some macros + buttons.
He asked me if it's possible to create an interface between the Excel and the SQL Server, like if you're using the DBMS, showing a userform to type the query and if you get some syntax error, it will be showed to you).
Here's my problem : I've created successfully the interface, but I cannot display the Syntax Error. It appears only the message : "Run Time Error '1004' SQL Syntax Error".
It's possible to show the exactly message like if you're using the DBMS?
To make it easier to understand, here's my code :
Function Query(SQL As String)
On Error GoTo Err_handler
With ActiveSheet.QueryTables.Add(Connection:= _
"ODBC;DSN=mydb;Description=test;UID=test;PWD=test;APP=Microsoft Office 2003;WSID=test123" _
, Destination:=Range("A1"))
.CommandText = (SQL)
.Name = "test"
.FieldNames = True
.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
Exit Function
Err_handler:
MsgBox Err.Number & " - " & Err.Description
End Function
Thanks in advance!
You need to use something like the ActiveX Data Objects library (ADODB) so you can get specific connection information. Therefore, when you run the code, the SQL will raise an error on the ADO object, but then the Err object will contain SQL-specific error information bubbled up from the database.
You need to add a Reference to ActiveX Data Objects in your VBA project. Once you have done that, then try this:-
Function MyQuery(SQL As String)
Dim cn As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
On Error GoTo Err_handler
'DB Connection Object
Set cn = New ADODB.Connection
cn.Open "DSN=mydb;Description=test;UID=test;PWD=test;APP=Microsoft Office 2003;WSID=test123"
'SQL Command Object
Set cmd = New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdText
cmd.CommandText = SQL
'Recordset Object to contain results
Set rs = cmd.Execute
With ActiveSheet.QueryTables.Add(Connection:=rs, Destination:=Range("A1"))
.Name = "test"
.FieldNames = True
.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
MyQueryx:
'Clean up - close connections and destroy objects
If Not rs Is Nothing Then
If rs.State = ADODB.adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
If Not cmd Is Nothing Then
Set cmd.ActiveConnection = Nothing
Set cmd = Nothing
End If
If Not cn Is Nothing Then
If cn.State = ADODB.adStateOpen Then
cn.Close
End If
Set cn = Nothing
End If
Exit Function
Err_handler:
MsgBox Err.Number & " - " & Err.Description
'Goto to the function exit to clean up
GoTo MyQueryx
End Function
I have more than 50 files needed to create the pivot table and each file has the same exact formort with different contents. So far, I have finished creating the code for the pivot and it works very well when running alone, however, it failed when I tried to run the code for all workbooks in the same folder. I don't know what happened and why it kept showing that no files could be found despite nothing wrong about the pathname.
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
Pathname = "D:\Reports"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = Workbooks.Open(Pathname & Filename) 'open all files
PivotX WB
WB.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Filename = Dir()
Loop
End Sub
Here is the code for pivot and it works very well when running it alone:
Sub PivotX(WB As Workbook)
Dim Lrow, Lcol As Long
Dim wsData As Worksheet
Dim rngRaw As Range
Dim PvtTabCache As PivotCache
Dim PvtTab As PivotTable
Dim wsPvtTab As Worksheet
Dim PvtFld As PivotField
Set wsData = ActiveSheet
Lrow = wsData.Cells(Rows.Count, "B").End(xlUp).Row
Lcol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column
Set rngRaw = wsData.Range(Cells(1, 1), Cells(Lrow, Lcol))
Set wsPvtTab = Worksheets.Add
wsData.Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngRaw, Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=wsPvtTab.Range("A3"), TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion12
Set PvtTab = wsPvtTab.PivotTables("PivotTable1")
PvtTab.ManualUpdate = True
Set PvtFld = PvtTab.PivotFields("Month")
PvtFld.Orientation = xlPageField
PvtTab.PivotFields("Month").ClearAllFilters
Set PvtFld = PvtTab.PivotFields("Year")
PvtFld.Orientation = xlPageField
PvtTab.PivotFields("Year").ClearAllFilters
Set PvtFld = PvtTab.PivotFields("Fund_Code")
PvtFld.Orientation = xlRowField
PvtFld.Position = 1
Set PvtFld = PvtTab.PivotFields("Curr")
PvtFld.Orientation = xlColumnField
PvtFld.Position = 1
wsPvtTab.PivotTables("PivotTable1").PivotFields("Curr").PivotItems("USD").Position = 1
With PvtTab.PivotFields("Trx_Amount")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0;[red](#,##0)"
End With
wsPvtTab.PivotTables("Pivottable1").RowAxisLayout xlTabularRow
'Remove grand total
wsPvtTab.PivotTables("Pivottable1").RowGrand = False
For Each PvtTbCache In ActiveWorkbook.PivotCaches
On Error Resume Next
PvtTbCache.Refresh
Next PvtTbCache
'Determine filter value
Set PvtFld = PvtTab.PivotFields("Year")
PvtFld.ClearAllFilters
PvtFld.EnableMultiplePageItems = True
With PvtFld
.AutoSort xlmnual, .SourceName
For Each Pi In PvtFld.PivotItems
Select Case Pi.Name
Case "2014"
Case Else
Pi.Visible = False
End Select
Next Pi
.AutoSort xlAscending, .SourceName
End With
'determine filter value
Set PvtFld = PvtTab.PivotFields("Month")
PvtFld.ClearAllFilters
PvtFld.EnableMultiplePageItems = True
With PvtFld
.AutoSort xlmnual, .SourceName
For Each Pi In PvtFld.PivotItems
Select Case Pi.Name
Case "11"
Case Else
Pi.Visible = False
End Select
Next Pi
.AutoSort xlAscending, .SourceName
End With
PvtTab.ManualUpdate = False
End Sub
Any help would be very much appreciated. Thank you very much in advance.
This should solve your problem:
Set WB = Workbooks.Open(Pathname & "\" & Filename)
When I tried using your code, for some reason, it did not retain the backslash you put at the beginning of the "Filename" variable. That would explain why VBA couldn't find the files. Adding it back should between the path name and file name should make it work correctly
I believe you have the answer to your base problem above but I would offer the following 'tweaks' to avoid screen flashing and unrecovered variable assignment.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do While Filename <> ""
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Call PivotX(WB)
WB.Close SaveChanges:=True
Set WB = Nothing
Filename = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
The Set WB = Nothing is really only purposeful on the last pass when WB is not reassigned but your PivotX sub could use several Set nnn = Nothing before exiting. While the reference count is supposed to be decremented (and memory consequently released), that is not always the case. (see Is there a need to set Objects to Nothing inside VBA Functions) In short, it is just good coding practise.
Finally, using Dim Filename, Pathname As String declares Filename as a variant, not a string type. It isn't making any difference here but you should be aware of what your variables are being declared as.
Using Dreamweaver CS5 I have added the following Server Behaviour which is working fine.
Question is, do I need to .Close the MM_rsUser1?
The auto-generated code closes the MM_rsUser, but when I tried to close the MM_rsUser1 on the lines before or after where the MM_rsUser is closed, the page fails.
I found this reference for MySql that seems to indicate I may not 'need' to, but as this is my first project, I am trying to learn as many 'good habits' as possible...and since Dreamweaver is generating much of the VB code, I don't want to 'assume' what it does for me is necessarily the best practice today. (The project is adding dynamic data and editing said data to a pre-exising Classic ASP site...my next project will be upgrading it to MVC/C#)
<%
' *** Validate request to log in to this site.
MM_LoginAction = Request.ServerVariables("URL")
If Request.QueryString <> "" Then MM_LoginAction = MM_LoginAction + "?" + Server.HTMLEncode(Request.QueryString)
MM_valUsername = CStr(Request.Form("userid"))
If MM_valUsername <> "" Then
Dim MM_fldUserAuthorization
Dim MM_redirectLoginSuccess
Dim MM_redirectLoginFailed
Dim MM_loginSQL
Dim MM_rsUser
Dim MM_rsUser_cmd
Dim MM_loginUpdate ' used to execute timestamp to log last successful login for user
Dim MM_rsUser1 ' also used to execute timestamp as above
MM_fldUserAuthorization = "accessLevel"
MM_redirectLoginSuccess = "/sql.asp"
MM_redirectLoginFailed = "/login.asp"
MM_loginSQL = "SELECT email, password"
If MM_fldUserAuthorization <> "" Then MM_loginSQL = MM_loginSQL & "," & MM_fldUserAuthorization
MM_loginSQL = MM_loginSQL & " FROM table WHERE userid = ? AND pword = ?"
Set MM_rsUser_cmd = Server.CreateObject ("ADODB.Command")
MM_rsUser_cmd.ActiveConnection = MM_SQL_STRING
MM_rsUser_cmd.CommandText = MM_loginSQL
MM_rsUser_cmd.Parameters.Append MM_rsUser_cmd.CreateParameter("param1", 202, 1, 50, MM_valUsername) ' adVarWChar
MM_rsUser_cmd.Parameters.Append MM_rsUser_cmd.CreateParameter("param2", 202, 1, 50, Request.Form("password")) ' adVarWChar
MM_rsUser_cmd.Prepared = true
Set MM_rsUser = MM_rsUser_cmd.Execute
If Not MM_rsUser.EOF Or Not MM_rsUser.BOF Then
' username and password match - this is a valid user
Session("MM_Username") = MM_valUsername
MM_loginUpdate = "UPDATE table SET lastLoggedIn = { fn NOW() } WHERE userid = '" & MM_valUsername & "'"
MM_rsUser_cmd.CommandText = MM_loginUpdate
Set MM_rsUser1 = MM_rsUser_cmd.Execute ' unsure if I have to write an MM_rsUser1.Close somewhere or not, but page fails where I've tried
If (MM_fldUserAuthorization <> "") Then
Session("MM_UserAuthorization") = CStr(MM_rsUser.Fields.Item(MM_fldUserAuthorization).Value)
Else
Session("MM_UserAuthorization") = ""
End If
if CStr(Request.QueryString("accessdenied")) <> "" And true Then
MM_redirectLoginSuccess = Request.QueryString("accessdenied")
End If
MM_rsUser.Close
Response.Redirect(MM_redirectLoginSuccess)
End If
MM_rsUser.Close
Response.Redirect(MM_redirectLoginFailed)
End If
%>
The code is a little tricky, at first look. I see 2 statements that close MM_rsUser. The Response.Redirect() acts like a return statement, so only one or the other will be executed, even though the IF block tends to make it look otherwise. I think the key for you is that you can't close MM_rsUser1 if you don't enter the IF block, because it never was opened. So I would suggest this:
If Not MM_rsUser.EOF Or Not MM_rsUser.BOF Then
' username and password match - this is a valid user
Session("MM_Username") = MM_valUsername
MM_loginUpdate = "UPDATE table SET lastLoggedIn = '" & NOW() & "' WHERE userid = '" & MM_valUsername & "'"
MM_rsUser_cmd.CommandText = MM_loginUpdate
Set MM_rsUser1 = MM_rsUser_cmd.Execute ' unsure if I have to write an MM_rsUser1.Close somewhere or not, but page fails where I've tried
If (MM_fldUserAuthorization <> "") Then
Session("MM_UserAuthorization") = CStr(MM_rsUser.Fields.Item(MM_fldUserAuthorization).Value)
Else
Session("MM_UserAuthorization") = ""
End If
if CStr(Request.QueryString("accessdenied")) <> "" And true Then
MM_redirectLoginSuccess = Request.QueryString("accessdenied")
End If
MM_rsUser1.Close 'close it here
MM_rsUser.Close
Response.Redirect(MM_redirectLoginSuccess)
End If 'Not MM_rsUser.EOF Or Not MM_rsUser.BOF
'not open, so don't close it
MM_rsUser.Close
Response.Redirect(MM_redirectLoginFailed)
End If 'MM_valUsername <> ""
Update
Reusing MM_rsUser_cmd is confusing at best, and could be a cause of some of the errors. Change
MM_rsUser_cmd.CommandText = MM_loginUpdate
Set MM_rsUser1 = MM_rsUser_cmd.Execute
to
Dim MM_rsUser_cmd1
Set MM_rsUser_cmd1 = Server.CreateObject ("ADODB.Command")
MM_rsUser_cmd1.ActiveConnection = MM_SQL_STRING
MM_rsUser_cmd1.CommandText = MM_loginUpdate
MM_rsUser_cmd1.Parameters.Append MM_rsUser_cmd1.CreateParameter("param1", 135, 1, -1, NOW()) ' adDBTimeStamp
MM_rsUser_cmd1.Parameters.Append MM_rsUser_cmd1.CreateParameter("param2", 202, 1, 50, MM_valUsername) ' adVarWChar
MM_rsUser_cmd1.Prepared = true
Set MM_rsUser1 = MM_rsUser_cmd1.Execute