My code I've written so far takes the username, computername and current datetime and writes it to a SQL table. What I want to do is capture when different sheets are selected and the timestamp associated with each.
Sub UpdateTable()
Dim cnn As ADODB.Connection
Dim uSQL As String
Dim strText As String
Dim strDate As Date
Dim strUsername As String
Dim strComputerName As Variant
strUsername = Environ("username")
strComputerName = Environ("Computername")
strDate = Now
Set cnn = New Connection
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=icl-analive; " & _
"Initial Catalog=DW_ALL;" & _
"User ID=dw_all_readonlyuser;" & _
"Trusted_Connection=Yes;"
cnn.Open cnnstr
uSQL = "INSERT INTO Audit (UN,CN,DT) VALUES ('" & strUsername & "','" & strComputerName & "','" & strDate & "');" ''
Debug.Print uSQL
cnn.Execute uSQL
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub
I'm not too sure if I'm oversimplifying this but from what I understand:
Add the UpdateTable() sub to a Module. Add a Worksheet_Activate() event to each worksheet you want to run UpdateTable().
When the worksheet is selected the UpdateTable() sub will run, which will add the username, computer name and timestamp to your database. It may be worth adding the worksheet name (if you're looking to run this across multiple worksheets)
Therefore, when a worksheet is selected you could add the Application.ActiveSheet.Name and any other values (timestamp, user, etc) to the database.
Related
I have a workbook with 147 tables across different worksheets (most worksheets have multiple tables and new tables are added regularly).
I need to
create connection-only queries for each of the tables,
edit them (Remove all Columns except two, transpose the remaining two columns and then turn the first row into Column headers) and
name them in a particular pattern e.g. ConnectionTable1 and so on.
This process needs to be followed for each new table added to the workbook.
I would like to automate this using VBA. So far I have the following code (found from searching on the web) which creates connection-only queries for all of the tables in the workbook and adds the data to the Data Model.
Code:
Sub CreateConnectionToAllTables()
‘Creates Connection Only Queries to all tables in the active workbook.
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject
Dim sName As String
Dim sFormula As String
Dim wq As WorkbookQuery
Dim bExists As Boolean
Dim vbAnswer As VbMsgBoxResult
Dim vbDataModel As VbMsgBoxResult
Dim i As Long
Dim dStart As Double
Dim dTime As Double
‘Display message box to prompt user to run the macro
vbAnswer = MsgBox(“Do you want to run the macro to create connections for all Tables in this workbook?”, vbYesNo, “Power Query Connect All Tables Macro”)
If vbAnswer = vbYes Then
‘Prompt user for Data Model option
vbDataModel = MsgBox(“Do you want to add the data to the Data Model?”, vbYesNo + vbDefaultButton2, “Power Query Connect All Tables Macro”)
‘Set variables
dStart = Timer
Set wb = ActiveWorkbook
‘Loop sheets and tables
For Each ws In ActiveWorkbook.Worksheets
For Each lo In ws.ListObjects
sName = lo.Name
sFormula = “Excel.CurrentWorkbook(){[Name=””” & sName & “””]}[Content]”
‘Check if query exists
bExists = False
For Each wq In wb.Queries
If InStr(1, wq.Formula, sFormula) > 0 Then
bExists = True
End If
Next wq
‘Add query if it does not exist
If bExists = False Then
‘Add query
wb.Queries.Add Name:=sName, _
Formula:=”let” & Chr(13) & “” & Chr(10) & ” Source = Excel.CurrentWorkbook(){[Name=””” & sName & “””]}[Content]” & Chr(13) & “” & Chr(10) & “in” & Chr(13) & “” & Chr(10) & ” Source”
‘Add to Data Model
If vbDataModel = vbYes Then
wb.Connections.Add2 Name:=”Query – ” & sName, _
Description:=”Connection to the ‘” & sName & “‘ query in the workbook.”, _
ConnectionString:=”OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=” & sName & “;Extended Properties=”, _
CommandText:=”” & sName & “”, _
lCmdtype:=6, _
CreateModelConnection:=True, _
ImportRelationships:=False
‘Add connection only
Else
wb.Connections.Add2 Name:=”Query – ” & sName, _
Description:=”Connection to the ‘” & sName & “‘ query in the workbook.”, _
ConnectionString:=”OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=” & sName & “;Extended Properties=”””””, _
CommandText:=”SELECT * FROM [” & sName & “]”, _
lCmdtype:=2, _
CreateModelConnection:=False, _
ImportRelationships:=False
End If
‘Count connections
i = i + 1
End If
Next lo
Next ws
‘Calc run time
dTime = Timer – dStart
MsgBox i & ” connections have been created in ” & Format(dTime, “0.0”) & ” seconds.”, vbOKOnly, “Process Complete”
End If
End Sub
The above code works fine. But I need help modifying it to perform steps (2) editing the queries and (3) naming them in a particular pattern slightly different from the name of the table they are connected to.
Disclaimer: I am very new to this and would appreciate any help with this problem.
Example:
Source Tables:
Result Table:
This is how you combine all tables in workbook:
let
Source = Excel.CurrentWorkbook()
,Expand = Table.ExpandTableColumn(Source, "Content", {"Info T", "Info"}, {"Info T", "Info"})
in
Expand
Then you just do additional transformation that you need (probably pivot column).
Good Afternoon,
I have created a Macro that uploads data to a access database ( both on my desktop). The problem is it I keep getting errors when I try to expand the range.
I presumed it would be something simple but seems to be something I am overlooking.
here is the code - basically I would like to include the column or set it to a dynamic range? can you please help?
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
rs.AddNew
rs.Fields("GUID") = Range("g2").Value
rs.Fields("StageID") = Range("h2").Value
rs.Fields("Sync Date") = Range("i2").Value
rs.Fields("Forecast HP") = Range("j2").Value
rs.Fields("Owner Id") = Range("k2").Value
rs.Fields("Recent Modified Flag") = Range("L2").Value
rs.Fields("Upload Date") = Range("M2").Value
rs.Update
rs.Close
db.Close
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
You can use a query instead of iterating through a recordset:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
db.Execute "INSERT INTO [Fact Table] ([GUID], [StageID], etc) " & _
"SELECT * FROM [SheetName$G:M] " & _
"IN """ & ActiveWorkbook.FullName & """'Excel 12.0 Macro;HDR=No;'"
End Sub
This has numerous advantages, such as often being faster because you don't have to iterate through all the fields.
If you would trigger the import from Access instead of Excel, you wouldn't even need VBA to execute the query.
Change the rs section to this one:
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
End With
MSDN source
Use the AddNew method to create and add a new record in the Recordset object named by recordset. This method sets the fields to default values, and if no default values are specified, it sets the fields to Null (the default values specified for a table-type Recordset).
After you modify the new record, use the Update method to save the changes and add the record to the Recordset. No changes occur in the database until you use the Update method.
Edit:
This is how your code should look like, when you change the rs section with the code above:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
.Close
End With
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
Just thought I'd add in an alternative to #Erik von Asmuth's excellent answer. I use something like this in a real project. It's a little more robust for importing a dynamic range.
Public Sub ImportFromWorksheet(sht As Worksheet)
Dim strFile As String, strCon As String
strFile = sht.Parent.FullName
strCon = "Excel 12.0;HDR=Yes;Database=" & strFile
Dim strSql As String, sqlTransferFromExcel As String
Dim row As Long
row = sht.Range("A3").End(xlDown).row
Dim rng As Range
sqlTransferFromExcel = " Insert into YourTable( " & _
" [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" ) " & _
" SELECT [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" FROM [{{connString}}].[{{sheetName}}$G2:M{{lastRow}}]"
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{lastRow}}", row)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{connString}}", strCon)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{sheetName}}", sht.Name)
CurrentDb.Execute sqlTransferFromExcel
End Sub
I have a sheet that looks like this:
I have VBA code that launches an email and takes data from the sheet and puts it in the email body based on an inputbox value that is searched for in the sheet. Values are grabbed from the row based on finding that value. What I am having trouble with now is we have many dupes and I want to pull a name only once, and then getting it to loop, creating a new email when it hits a new approver name, then grabbing all of that approver's customers, and so on.
Example from above sheet:
Email says 'Dear Chris,
Your customers Thomas, Mark, and Jared all need to be reviewed."
So I need code that gets all customers (column C) assigned to one approver (column E), but only grabs one instance of each customer name.
Then, it creates a new separate email when it finds the next approver, in this case John. So the approver name becomes a delimiter.
I am unsure how to do this, or what is even the best approach. Can anyone offer up any ideas? I am learning, but this part is giving me trouble.
Here is the code I have so far:
Sub Test()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim x As Long
Dim r As Long
Dim lr, lookRng As Range
Dim findStr As String
Dim foundCell As Variant
Dim foundcell1 As Variant
Dim foundcell2 As Variant
Dim strbody As String
Dim sigstring As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter approver name to find")
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Search for input box values and set fields to be pulled
lr = Cells(Rows.Count, "c").End(xlUp).Row
Set lookRng = Range("d1:d" & lr)
valuefound = False
For x = 1 To lr
If Range("c" & x).Value = findStr Then
Set foundCell = Range("B" & x).Offset(0, 4)
Set foundcell1 = Range("e" & x).Offset(0, 1)
Set foundcell2 = Range("B" & x).Offset(0, 5)
valuefound = True
End If
Next x
'Ends the macro if input values to not match the sheet exactly
If Not valuefound Then
MsgBox "Is case-sensitive, Must be exact name", vbExclamation, "No
Match!"
Exit Sub
End If
The way I would approach this is to query your table using SQL to exclude any duplicates (I adapted this example), then iterate over the returned recordset using a dictionary to store your approvers and their customers.
To get the below example to work I've added the Microsoft ActiveX Data Objects 6.1 Library (for the SQL), and the Microsoft Scripting Runtime (for the dictionary), I believe it does what you need:
Sub GetApproversAndCustomers()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
'only retrieve unique combinations of approvers and customers
strSQL = "SELECT DISTINCT [Approver Name],[Customer Name] FROM [Sheet1$B1:E11]"
rs.Open strSQL, cn
Dim approvers As Dictionary
Set approvers = New Dictionary
Do Until rs.EOF
'only add the approver to the collection if they do not already exist
If approvers.Exists(rs.Fields("Approver Name").Value) = False Then
'if they dont exist, add both the approver and customer to the dictionary
approvers.Add rs.Fields("Approver Name").Value, rs.Fields("Customer Name").Value
Else
'if they do exist, find the approver and add the customer to the existing list
approvers.Item(rs.Fields("Approver Name").Value) = approvers.Item(rs.Fields("Approver Name").Value) & ", " & rs.Fields("Customer Name").Value
End If
rs.MoveNext
Loop
'iterate over the dictionary, outputting our values
Dim strKey As Variant
For Each strKey In approvers.Keys()
Debug.Print "Dear " & strKey & ", Your customer(s) " & approvers(strKey) & " all need to be reviewed."
Next
End Sub
Here's a version that doesn't use SQL, I hope it works better than the previous one!
It loops over the table until there are no more rows with data in. It creates a dictionary of approvers and adds the corresponding customer (using the offset method) unless that customer has already been added.
Option Explicit
Public Function GetApproversAndCustomers2(ByVal approversColumn As String, ByVal customerNameColumn As String)
Dim approvers As Object
Set approvers = CreateObject("Scripting.Dictionary")
Dim iterator As Integer
iterator = 2
Do While Len(Sheet1.Range(approversColumn & iterator).Value) > 0
Dim approver As String
approver = Sheet1.Range(approversColumn & iterator).Value
If Not approvers.Exists(approver) Then
If Len(approver) > 0 Then
approvers.Add approver, Sheet1.Range(approversColumn & iterator).Offset(0, -2)
End If
Else
If InStr(1, approvers.Item(approver), Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value) = 0 Then
approvers.Item(approver) = approvers.Item(approver) & ", " & Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value
End If
End If
iterator = iterator + 1
Loop
iterator = 2
Dim key As Variant
For Each key In approvers.Keys
Debug.Print "Dear " & key & ", Your customer(s) " & approvers(key) & " all need to be reviewed."
Next
End Function
Here I'm getting error at
Dim strDate As Date
as type mismatch run time error..
Please any help will be appreciated....
Sub Insert11()
'click on tools and select Microsoft ActiveX data Objects 2.0 Library
Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim strDate As Date
Dim strWeight As Variant
Dim strMed_Id As Variant
Dim strGlucose As Variant
strDate = InsertForm.TextBox1.Value
strWeight = InsertForm.TextBox2.Value
strMed_Id = InsertForm.ListBox2.Value
strGlucose = InsertForm.TextBox3.Value
' InsertForm.Show
Cells.Clear
'Database path info
DBFullName = "C:\Users\ND5036832\Downloads\Assignment1234\Sample1.accdb"
'open the connection
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect
'Create RecordSet
Set Recordset = New ADODB.Recordset
With Recordset
'filter Data
Source = "Insert into Glucose ([Date],Weight, Med_Id,Glucose) values ( " & strDate & "," & strWeight & "," & strMed_Id & "," & strGlucose & ");"
.Open Source:=Source, ActiveConnection:=Connection
'Msgbox " The query:" & vbNewLine & vbNewLine & Source
'Write field names
For Col = 0 To Recordset.Fields.Count - 1
Range("G1").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next
'Write recordset
'Range("G1").Offset(1, 0).CopyFromRecordset Recordset
End With
ActiveSheet.Columns.AutoFit
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
End Sub
Well, a TextBox contains Text (known as a String). If you try to put a String into a Date variable then I'm not surprised you get an error. Try:
strDate = CDate(InsertForm.TextBox1.Value)
This converts, or casts your string to a date. If you don't give it a string in date format it will, again, throw an error.
Furthermore. Be careful how you name your variables. strDate has "str" at the beginning to remind you that you're dealing with a String so you'd expect to see this:
Dim strDate As String
Since your variable will be in Date format, consider renaming it to something like:
Dim dtDate As Date
Or much better, ignore this Hungarian style naming convention and just name it something that has more meaning, like:
Dim selectedDate As Date
I have an excel file(Lets' say File X) with 2 sheets. In first sheet I display charts. Second I have data for the chart. In order to get data from chart, I need to process that data as we do in SQL like Group by, order by. Is there any way I can use oledb to read data from second sheet using VBA code in same excel file(file X)?
Thanks!!
Here's an example of using SQL to join data from two ranges: it will work fine if the file is open (as long as it has been saved, because you need a file path).
Sub SqlJoin()
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath
Dim sSQL As String
sSQL = "select a.blah from <t1> a, <t2> b where a.blah = b.blah"
sSQL = Replace(sSQL, "<t1>", Rangename(Sheet1.Range("A1:A5")))
sSQL = Replace(sSQL, "<t2>", Rangename(Sheet1.Range("C1:C3")))
If ActiveWorkbook.Path <> "" Then
sPath = ActiveWorkbook.FullName
Else
MsgBox "Workbook being queried must be saved first..."
Exit Sub
End If
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sPath & "';" & _
"Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
oRS.Open sSQL, oConn
If Not oRS.EOF Then
Sheet1.Range("E1").CopyFromRecordset oRS
Else
MsgBox "No records found"
End If
oRS.Close
oConn.Close
End Sub
Function Rangename(r As Range) As String
Rangename = "[" & r.Parent.Name & "$" & _
r.Address(False, False) & "]"
End Function