I'm currently working on an Excel application that can get info from my Form worksheet and display it into Display worksheet. So far the data can transfer perfectly, except for one tiny quirk.
The Display worksheet will display data when Execute is clicked.
Here is the screenshot:
Before I execute the Display, the Time field in the Form worksheet is formatted as h:mm AM/PM. However, when I click Execute in Display worksheet, the Time format suddenly changed in the Form Worksheet as seen here:
Furthermore the change in format is also seen in the Display table as well. I tried setting the format to be identical for both worksheets and the result is still the same.
Is it the issue of the SQL1 statement or the coding in general? here is the code sample.
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String, AB As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String
On Error GoTo ErrHandler
If AB = "1st" Then
wbWorkBook = ActiveWorkbook.Sheets("Inner Workings").Range("B9").Text
End If
Application.StatusBar = "Retrieving data ....."
'Set up the connection string to excel - thisworkbook
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=Excel 8.0;"
Set rsData = New ADODB.Recordset
'Run the query as adCmdText
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText
'Check if data is returned
If Not rsData.EOF Then
'if the recordset contains data put them on the worksheet
rgStart.CopyFromRecordset rsData
Else
End If
'Close connection
rsData.Close
'Clean up and get out
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub
Sub process()
Call clear
Call testsql("1st") ' populate 1st Summary
Call testsql("2nd") ' find Date+Time
Call testsql("3rd") ' GET LATEST RECORD
End Sub
Sub testsql(AB As String)
Dim rgPlaceOutput As Range 'first cell for the output of the query
Dim stSQLstring As String 'text of the cell containing the SQL statement
Dim rg As String, SQL As String
If AB = "1st" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B2").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("1st Summary").Range("A2")
End If
If AB = "2nd" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B3").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("2nd Summary").Range("A2")
End If
If AB = "3rd" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B4").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("Final Summary").Range("A5")
End If
QueryWorksheet stSQLstring, rgPlaceOutput, ThisWorkbook.FullName, AB
End Sub
Sub clear()
ActiveWorkbook.Sheets("1st Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("2nd Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("Final Summary").Range("A2:BR5000").Value = Empty
End Sub
If anyone can help with this, I greatly appreciate it.
Update:
Apparently, this quirk is larger than I thought. After more testing I found out that the second summary sheet is also affected as well as seen here. . Albeit the lower half at least. The mystery keeps piling up...
I think you have to look at NumberFormat iirc add something like "DD/MM/YYYY" to a Range (columns in your case). I'm on a Mac with Office 365, and although VBA is now in the app, the sort of intellisense is absent so unless you know the Excel Object model by heart it's a royal PITA!
Related
Here is the full code:
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim frm As Access.Form
Dim i As Long
'For readability
Set frm = Forms!Frm_JobTicket
'Open Tbl_Schedule for adding Schedule Dates
Set db = CurrentDb
Set rs = db.OpenRecordset("Tbl_Schedule", dbOpenDynaset, dbAppendOnly)
'Creates loop for fields 1-14. Sets Date_ScheduledX = Forms!Frm_JobTicket!Txt_DateScheduledX. Runs through Loop then closes recordset
rs.AddNew
For i = 1 To 14
If (Not IsNull(frm("Txt_DateScheduled" & i & "_JobTicket"))) Then
rs("Date_Scheduled" & i) = frm("Txt_DateScheduled" & i & "_JobTicket")
End If
Next i
'Adds in Sales Order Number to Tbl_Schedule
rs!Sales_Order_Number = frm("Sales_Order_Number")
'Adds in Part Number to Tbl_Schedule
rs!Part_Number = frm("Part_Number")
'Adds updates and closes table
rs.Update
rs.Close
'Shows message box to inform the User if item was Scheduled
MsgBox "Item Scheduled."
'Runs Private Sub above. Clears all values from DateScheduled1-14 on Frm_JobTicket to null
ClearFields
'Clears DB and RS to null
Set db = Nothing
Set rs = Nothing
The line that doesn't work is this rs("Date_Scheduled" & i) = frm("Txt_DateScheduled" & i & "_JobTicket"). Sometimes it will run perfectly fine, and other times it gives me an endless flow of 3421 Data type conversion errors. I do not know what could be going wrong, none of the fields have default values, all of the fields in the table side are Date/Time with this same format, and now I am checking for nulls.
Any help would be greatly appreciated!!
Maybe something like
If Len(Me.Txt_DateScheduled & vbNullString) > 0 Then
rs("Date_Scheduled" & i) = frm("Txt_DateScheduled" & i & "_JobTicket")
Else
rs("Date_Scheduled" & i) = ""
End If
This is completely untested, but I think you should get the concept.
I have a code in vba through which whenever i will save any new value in a particular cell it will show in the message box that what was the old value stored in the cell and what was the new value which i have just saved below is the code for that
Option Explicit
Dim OldVals As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myCell As Range
For Each myCell In Target
If OldVals.Exists(myCell.Address) Then
MsgBox "New value of " & Replace(myCell.Address, "$", "") & " is " & myCell.Value & "; old value was " & OldVals(myCell.Address)
Else
MsgBox "No old value for " + Replace(myCell.Address, "$", "")
End If
OldVals(myCell.Address) = myCell.Value
Next myCell
End Sub
the output window of the code will come like this in the picture below --
so i want to export the values which was displayed in the message box to the access database table using vba one after the another
however i have written a code to export and save the values of excel sheet cells into access database table the code is below
Const TARGET_DB = "\Database3.accdb"
Sub PushTableToAccess()
Dim cnn As ADODB.Connection
Dim MyConn
Dim rst As ADODB.Recordset
Dim i As Long, j As Long
Dim Rw As Long
Sheets("Sheet1").Activate
Rw = Range("A1").End(xlDown).Row
Set cnn = New ADODB.Connection
MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
With cnn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open MyConn
End With
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseServer
rst.Open Source:="Table1", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
For i = 2 To Rw
rst.AddNew
For j = 1 To 3
rst(j) = Cells(i, j).Value
Next j
rst.Update
Next i
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Sub
the above code will export and save all the values in excel cells to access database table .
but i am not sure how to combine both the codes so that my first code whenever it will display the old and new values of cell and when i click on OK button it will export and save the value displayed in message box (eg- new value of A1 is 7 ; old value was 88) to access database table one after the another .
It seems you want to make an audit/logging function of all changes to a an Excel workbook.
You have two pieces of code, one to identify the change and one to write information to a datbase, an you want to combine this. The resulting functionality wold then be to write every change the user makes to a database.
The code you have should give you enough guidance on the particular VBA statements. I'll limit this solution to the approach.
As you will need the database connection during the whole time the user has the worksheet opened, you should make the database connection in the Workbook Open event:
Public cnn As ADODB.Connection
Public MyConn
Private Sub Workbook_Open()
Set cnn = New ADODB.Connection
MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
With cnn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open MyConn
End With
End Sub
Then you continue in the Change events:
Private Sub Worksheet_Change(ByVal Target As Range)
'.... (your code to get the change)
Set rst = New ADODB.Recordset
rst.AddNew ' allocate new record
rst(j) = Cells(i, j).Value ' populate the record (this must be your code)
rst.Update ' update/insert record
rst.Close ' done record.
End Sub
Finally you close the database in the Workbook_BeforeClose event.
I tried to search value of cell from outlook script and check whether Does it exist in excel file, if yes, open excel file, else do nothing. I can open file and search where is that value in range. But my problem is I don't know how to search that value in range and get it's position without open excel file.
EDIT 1:
Here is my detail issue: EX:
I have a phone number at column "Phone Number". I would like to find where Column of "Phone Number" (because sometime it will change to another column). After I find position of column, I would like to search whether number "123876" is existed in that column (until this time excel file still close). Now, if number "123876" is existed, open that excel file, else do nothing.
Here is my code to search if file open
Sub test()
Dim objExcel As Object
Dim WB As Object
Dim WS As Object
'Open excel file
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set WB = objExcel.Workbooks.Open("D:\Book1.xlsm")
WB.Activate
Set WS = WB.Worksheets("Sheet1")
'Search position of column "Phone Number"
Phone_Number_Col = Chr(WS.Range("A:Z").Find("Phone Number", LookIn:=xlValues).Column + 64) 'It will return 5 and change to "E" for this column
'Search whether does my number is exist in this file
Dim range_1 As Range
Set Found_Nprod = WS.Range(Phone_Number_Col & ":" & Phone_Number_Col).Find("123876", LookIn:=xlValues)
If Not Found_Nprod Is Nothing Then 'found my number
MsgBox ("This value is existed")
Else ' not find my number
MsgBox ("This value is not existed in this file")
End If
End Sub
Above code just can find when excel file is opened. But my problem is how to find like that without open file, It just open file when that file have my number "123876"
EDIT 2:
I found a peace of code which can get value of cell without open. It's run ok But I don't know how to use find function with it.
This is my function I found
Sub ReadClosed()
'
' Credit this To Bob Umlas
'
Dim strPath As String
Dim strFile As String
Dim strInfoCell As String
strPath = "D:\"
strFile = "Book1.xlsm"
i = 3
strInfoCell = "'" & strPath & "[" & strFile & "]Sheet1'!R" & i & "C1"
MsgBox "In Cell A1 = " & ExecuteExcel4Macro(strInfoCell), vbInformation, strFile
Ok, this is how I can help you with - this is a code, that I am using, and it gives you the row of the wanted string, if you give it in which column to search. If it is not the wanted string, it returns -1. If you want the second repetitable of the string, you should give in the optional parameter l_more_values_found a value of 2. If your string is Phone and in the sheet it is Phones, you should set look_for_part as True. Prety much this is how it works. Lets imagine you have this:
If you run the MyTest Sub, you would get 4 as a result. 4 is the phone number 155, which is given as a parameter to l_locate_value_row. In your case, you can check once you know the column that it has to search, whether it returns -1.
Here comes the code:
Public Function l_locate_value_row(target As String, ByRef target_sheet As Worksheet, _
Optional l_col As Long = 2, _
Optional l_more_values_found As Long = 1, _
Optional b_look_for_part = False) As Long
Dim l_values_found As Long
Dim r_local_range As Range
Dim my_cell As Range
l_values_found = l_more_values_found
Set r_local_range = Nothing
target_sheet.Activate
Set r_local_range = target_sheet.Range(target_sheet.Cells(1, l_col), target_sheet.Cells(Rows.Count, l_col))
For Each my_cell In r_local_range
'The b_look_for_part is for the vertriebscase
If b_look_for_part Then
If target = Left(my_cell, Len(target)) Then
If l_values_found = 1 Then
l_locate_value_row = my_cell.Row
Exit Function
Else
l_values_found = l_values_found - 1
End If
End If
Else
If target = Trim(my_cell) Then
If l_values_found = 1 Then
l_locate_value_row = my_cell.Row
Exit Function
Else
l_values_found = l_values_found - 1
End If
End If
End If
Next my_cell
l_locate_value_row = -1
End Function
Public Sub MyTest()
Dim l_col As Long
l_col = l_locate_value_row("155", ActiveSheet, 3, 1, False)
Debug.Print l_col
End Sub
An ADODB Query is ideal for retrieving data from a closed workbook.
Phone Numbers
Test
Code
Function hasPhoneNumber(FilePath As String, PhoneNumber As Variant) As Boolean
Const adOpenStatic = 3, adLockOptimistic = 3, adCmdText = 1
Dim conn As Object, rs As Object
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & FilePath & _
";Extended Properties=Excel 12.0;"
rs.Open "SELECT (Count([Phone Number]) > 0) AS hasPhoneNumber FROM [Sheet1$]" & _
" WHERE Cstr([Phone Number])='" & PhoneNumber & "';", conn, adOpenStatic, adLockOptimistic, adCmdText
hasPhoneNumber = CBool(rs!hasPhoneNumber)
On Error Resume Next
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
End Function
My difficulty is this: I have a Excel spreadsheet where I need a UserForm ListBox to populate itself with some rows of data depending on previous user input.
So the UserForm should pick up the user's input in Sheet1 (say it's 123abc) and then search for similar results in Sheet2. The nearest results (probably a range of about five similar results) should then fill the listbox.
So it could return something like 123a, 123ab, 1235c, and 1355abc from the list
Hope this makes sense - thanks for your help in advance.
The code I've tried (and doesn't work, turns a 1004) with notes for clarification:
Private Sub UserForm_Initialize()
Dim cs As Worksheet
Dim c As Range
Dim i As Integer
Dim code As Variant
Dim co As String
Set code = Sheets("Sheet1").Range("B4") 'picks up user input
co = Left(code, 2) 'just takes first two letters of input to find similar
Set cs = Sheets("Sheet2")
Set c = cs.Range("A2:A20000").Find(co) 'find code (obviously :))
For i = 1 To cs.Cells(c.Offset(5, 0), 1).End(xlUp).Row Step 1
If cs.Cells(i, 1).Value <> vbNullString Then Me.ListBox1.AddItem cs.Cells(i, 1).Value
Next i 'populate listbox
End Sub
Many thanks!
EDIT
I have marked the below as the accepted answer, but for others browsing this, the problem still exists as to integrating this with the template Excel files, as it returns the error 'External table is not in the expected format'. I had to change ThisWorkbook.FullName to the full template path to remove another error too.
Below is the aforementioned example. The code is mostly commented with what is needed. Please feel free to ask any questions.
I did a quick performance test searching for a text string in a data set of about 65,000 records. It look less than a second.
Here's the code:
'Making these variable public so they don't need to be recreated each time
'Make sure you add a reference to ADO through the tool-->references menu
Public MyConnection As New ADODB.Connection
Public MyRecordset As New ADODB.Recordset
Private Sub UserForm_Initialize()
Dim ColumnName As String: ColumnName = "[Number]" ' The name of the Column in Sheet2 you are searching for, it should have a header in row 1
Dim SearchStr As String: SearchStr = Left(Sheets("Sheet1").Range("B4").Value2, 2) ' This is what will be searched
If MyConnection.State <> adStateOpen Then
With MyConnection
'Connection string below is assuming you are using an XLSX file 2007 or higher
'It also assumes Sheet2 has column headers, e.g. HDR=Yes in the connection string
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1';"
.Open
End With
End If
If MyRecordset.State = adStateOpen Then MyRecordset.Close ' Make sure recordset is closed when open
MyRecordset.Open "Select top 5 " & ColumnName & " from [Sheet2$] where " & ColumnName & _
" like '%" & SearchStr & "%'", MyConnection, adOpenForwardOnly, adLockReadOnly
Me.ListBox1.Clear ' Clear all entries from the listbox
If Not MyRecordset.EOF Then MyRecordset.MoveFirst 'Move to start of recordset
Do Until MyRecordset.EOF 'Loop recordset and add all the items
Me.ListBox1.AddItem MyRecordset.Fields(0).Value
MyRecordset.MoveNext
Loop
End Sub
I am trying to output the value of a combobox field in Access, as a string, to an Excel worksheet.
I tried several solutions/hacks and get 445 errors.
The combobox is a dropdown list of communities or populations served by the member (e.g. Gay men, Aging populations, Trans*, People of Colour, Aboriginal Groups, Women, New Canadians, etc.). Several can be selected and there are some blank records.
Sub OutputSub()
' Define a recordset for the Table I am using
Dim myConnection As ADODB.Connection
Set myConnection = CurrentProject.Connection
Dim myRecordset As New ADODB.Recordset
myRecordset.ActiveConnection = myConnection
myRecordset.Open "MemberList", , adOpenStatic, adLockOptimistic
' Open Excel and make a worksheet for me
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
' Make Excel visible through the Application object.
xlSheet.Application.Visible = True
' Variables for each of the values I will need
Dim memCom As Variant, memServ As Variant, memLangs As Variant, memTot As Variant
Dim memNum As Integer
memNum = 2
xlSheet.Application.Cells(1, 4).Value = "Services"
'This loops through each of the records in the Table MemberList
myRecordset.MoveFirst
Do Until myRecordset.EOF()
memCom = myRecordset.Fields("Communities Served")
' This next line causes a 1004 error, application or object defined error
xlSheet.Application.Cells(memNum, 4).Value = memCom
'Debug.Print memCom, memServ, memLangs
memNum = memNum + 1
myRecordset.MoveNext
Loop
' Cleanup open files/variables, just in case
myRecordset.Close
Set myRecordset = Nothing
Set myConnection = Nothing
End Sub
My goal is an Excel sheet with the values much like if I exported the DB as an Excel file. There are three previous columns of information I need in specific formats (which I have working, so I cut them out).
From StackOverflow I have found little information on how to access the value of the combobox, and lots of tips on how to add fields to the box.
UPDATE: The runtime error 1004: Application defined or object defined error happens as noted in the code as a comment.
UPDATE 2: Further digging has yielded this from the Office Dev Center: https://social.msdn.microsoft.com/Forums/office/en-US/f5de518d-a2f0-41b8-bfd3-155052547ab5/export-of-combo-box-to-excel-with-values-access-2010?forum=accessdev.
I created a query that will output the info I need with the memName, but I'm lost as to how to make it part of this output.
If you step through your program what line causes the error - that's the first step to troubleshooting
What is the value coming out of the field "Communities Served" ? Is it a comma delimited string that you want split into multiple columns - or just to fill the once cell with whatever comes out - that's what it looks like to me?
In any case, get rid of your error by changing
xlSheet.Application.Cells(memNum, 4).Value = memCom
to
xlSheet.Cells(memNum, 4).Value = memCom
EDIT - memCom is coming back as a array Use Debug Watch to look at
how you need to access the value - probably even as simple as
memcon(0)
Thank you for the help from both #dbmitch and #Nathan_Sav, they helped me figure out what was wrong, so I could fix it.
For posterity sake, and for completion in case someone else has this issue, the solution was to make a query in Access for my multivalued combobox, and then make the value of that query into a recordset. Then I had to make a list of the values that the query returned, and then return that list into my excel sheet.
Here is my code:
Sub OutputSub()
' Define a recordset for the Table I am using
Dim myConnection As ADODB.Connection
Set myConnection = CurrentProject.Connection
Dim myRecordset As New ADODB.Recordset
myRecordset.ActiveConnection = myConnection
myRecordset.Open "MemberList", , adOpenStatic, adLockOptimistic
'Define a recordset for the query into my services
Dim myConnection2 As ADODB.Connection
Set myConnection2 = CurrentProject.Connection
Dim myServicesRecordset As New ADODB.Recordset
myServicesRecordset.ActiveConnection = myConnection2
myServicesRecordset.Open "SELECT MemberList.[Organization Name], MemberList.[Services Offered].Value FROM MemberList", , adOpenStatic, adLockOptimistic
' Open Excel and make a worksheet for me
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
' Make Excel visible through the Application object.
xlSheet.Application.Visible = True
' Variables for each of the values I will need
Dim memName As String, memSite As Variant
Dim memSoc As Variant, memNameHOLD
Dim memServ As Variant, memServHOLD As Variant, memServName As Variant
'Variable for the line in the database, and start it counting at 2, so there is space for Column headers
' Then give the column headers values.
Dim memNum As Integer
memNum = 2
xlSheet.Application.Cells(1, 1).Value = "Member Name"
xlSheet.Application.Cells(1, 4).Value = "Services"
'This loops through each of the records in the Table MemberList
myRecordset.MoveFirst
Do Until myRecordset.EOF()
' Sets the value of the variables to the content of the relevant field
memName = myRecordset.Fields("Organization Name")
memSite = myRecordset.Fields("Website")
'If there is content in the website field, then make the Org Name a link, else leave it as is.
If Not IsNull(memSite) Then
memNameHOLD = "" & memName & ""
Else
memNameHOLD = memName
End If
'Collect the Services offered into a list for this memName
myServicesRecordset.MoveFirst
Do Until myServicesRecordset.EOF()
memServ = myServicesRecordset.Fields(1)
memServName = myServicesRecordset.Fields(0)
If memServName = memName Then
memServHOLD = memServHOLD & memServ & ", "
Else
memServHOLD = memServHOLD
End If
myServicesRecordset.MoveNext
memServ = ""
Loop
xlSheet.Application.Cells(memNum, 1).Value = memNameHOLD
xlSheet.Application.Cells(memNum, 3).Value = memRegion
xlSheet.Cells(memNum, 4).Value = "Services Offered: " & memServHOLD
memNum = memNum + 1
myRecordset.MoveNext
'Clear the hold value
memServHOLD = ""
Loop
' Cleanup open files/variables, just in case
myRecordset.Close
Set myRecordset = Nothing
Set myConnection = Nothing
End Sub
The keen eye may still be able to tell me why there is a , in the output if there were no values. But all things considered, that small comma is an acceptable error.