I need a code where the user (after pasting data in a datasheet), when he clicks a button, the data will be inserted in a table (I was thinking of using an SQL statement here). In addition to that, one of the fields in that table will have to be calculated using the DCount function. So I need to calculate that per record. Let me know if the idea is not clear and I need to explain further. Also, if there are better ideas out there, do tell. Thanks!
Why not create some VBA to pull in the data from the spreadsheet, insert it into the table and then close down excel again. All in a button click
Take a look at the below for an example
Dim objApp As Excel.Application
Dim objBook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim sSQL As String
Dim Path As String
Set db = CurrentDb()
Set objBook = Workbooks.Add(Template:=SheetLocation) 'Your excel spreadsheet file goes here where "SheetLocation is typed
Set objApp = objBook.Parent
Set objSheet = objBook.Worksheets("Sheet1") 'Name of sheet you want to View
objBook.Windows(1).Visible = True
objApp.Visible = True
objApp.DisplayAlerts = False
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = CurrentProject.Connection
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "INSERT YOUR TABLE NAME HERE", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("INSERT THE TABLE FIELD TO DUMP DATA IN HERE") = Range("A" & r).Value
.Fields("REPEAT AS ABOVE") = Range("B" & r).Value
.Fields("REPEAT AS ABOVE") = Range("C" & r).Value
.Fields("REPEAT AS ABOVE") = Range("D" & r).Value
.Fields("REPEAT AS ABOVE") = Range("E" & r).Value
.Fields("REPEAT AS ABOVE") = Range("F" & r).Value
.Fields("REPEAT AS ABOVE") = Range("G" & r).Value
.Fields("REPEAT AS ABOVE") = Range("H" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
objApp.Quit
Related
I have a list of account ID in column A. The range of that column is dynamic. How do I write a module that will take those values and use them in an SQL IN statement. Below is my attempt at doing this. I pieced together multiple scripts I found so sorry if it is a mess.
Sub ConnectSqlServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lastrow As Long
Dim sl As Long
With wsSheet
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' Appending the values to a single variable
For i = 1 To lastrow
s1 = s1 & "'" & Val(wsSheet.Cells(i, 1)) & "'" & ","
Next
' Variable which could be used in IN command
If lastrow > 0 Then
s1 = Mid(s1, 1, Len(s1) - 1)
s1 = "(" & s1 & ")"
Else
Exit Sub
End If
' ' Create the connection string.
sConnString = "Driver={ODBC Driver 13 for SQL Server}; Server=snapshot;" & _
"Database=salesforce_replica;" & _
"Trusted_Connection=yes;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
' Open the connection and execute.
conn.Open sConnString
Set rs = conn.Execute("SELECT * FROM dbo.account where Account_ID_18__c = " & s1;)
' Check we have data.
If Not rs.EOF Then
' Transfer result.
Sheets(1).Range("A1").CopyFromRecordset rs
' Close the recordset
rs.Close
Else
MsgBox "Error: No records returned.", vbCritical
End If
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub
My goal is to figure out how to take a dynamic range of values and use them within an SQL Where statement.
Try something like this:
Sub ConnectSqlServer()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim sConnString As String
Dim wb As Workbook, ws As Worksheet, rngIds As Range, sql As String, inList As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("list")
Set rngIds = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
inList = InClause(rngIds)
If Len(inList) = 0 Then
MsgBox "No id values!"
Exit Sub 'nothing to query...
End If
sConnString = "Driver={ODBC Driver 13 for SQL Server}; Server=snapshot;" & _
"Database=salesforce_replica;" & _
"Trusted_Connection=yes;"
Set conn = New ADODB.Connection
conn.Open sConnString
Set rs = conn.Execute("SELECT * FROM dbo.account where Account_ID_18__c in " & inList)
If Not rs.EOF Then
wb.Sheets(1).Range("A1").CopyFromRecordset rs
Else
MsgBox "Error: No records returned.", vbCritical
End If
rs.Close
conn.Close
End Sub
'Generate a SQL "in" list from distinct values in range `rng`
' Add single quotes around values unless `IsNumeric` is True
' Note if `rng` has too many values you may exceed your max. SQL query size!
Function InClause(rng As Range, Optional IsNumeric As Boolean = False) As String
Dim c As Range, dict As Object, arr, qt As String, v
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then dict(v) = 1
Next c
If Not IsNumeric Then qt = "'"
If dict.Count > 0 Then
InClause = "(" & qt & Join(dict.keys, qt & "," & qt) & qt & ")"
End If
End Function
Please see code below for parsing data from json into MS Access tables using VBA. The first level (Order) works fine, it's the second level (OrderLine) that is getting an error, and not quite sure how to get the OrderDetailID (which is an auto-number) from the first table into the second table to be able to link. I have been using some code i found online and replicated but something not quite right. I'm using the Tim Hall VBA-json parser.
First error is Data type conversion error on line rs!OrderDetailID = Order("OrderID"). If i leave that line out then i get error Wrong number of arguments or invalid property assignment on line arrValues = Split(OrderLine, ",").
Any help much appreciated. Thanks
Json data retrieved:
{"Order":
[{"ShipLastName":"Bloggs",
"ShipFirstName":"Joe",
"OrderID":"INV1324",
"OrderType":"sales",
"OrderLine":
[{"Quantity":"1",
"SKU":"9045200017",
"OrderLineID":"INV1324-0"}],
"DeliveryInstruction":"",
"ShipPhone":"+6491234567",
"Email":"joe.bloggs#somecompany.com",
"ShippingOption":"Standard Shipping",
"ShipCompany":"Some Company Ltd",
"ShipStreetLine1":"58 Some Street",
"ShipCity":"Some City",
"ShipState":"Some State",
"ShipCountry":"NZ",
"CustomerRef1":"",
"DatePlaced":"2021-06-03 22:26:48",
"OrderStatus":"Pick",
"ShipPostCode":"2103"}],
"CurrentTime":"2021-09-21 05:10:24",
"Ack":"Success"}
Option Compare Database
Option Explicit
Dim arrValues() As String
Dim I As Integer
--------------------------
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim JsonText As Object
Dim Order As Variant
Dim OrderLine As Variant
'add order to tblOrderDetails
Set rs = db.OpenRecordset("tblOrderDetails", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
rs.AddNew
rs!Date = Format(Now(), "dd/mm/yyyy")
rs!Time = Format(Now(), "hh:nn")
rs!ClientID = 123
rs!OrderNo = Order("OrderID")
rs!DelPhone = Order("ShipPhone")
rs!NotifyEmailAddress = Order("Email")
rs!DelName = Order("ShipCompany")
rs!DelStreet = Order("ShipStreetLine1")
rs!DelSuburb = Order("ShipCity")
rs!DelCity = Order("ShipState")
rs!DelZipCode = Order("ShipPostCode")
rs!DelCountryID = DLookup("CountryID", "tblCountries", "CountryCode = '" & Order("ShipCountry") & "'")
rs!DelContactName = Order("ShipFirstName") & " " & Order("ShipLastName")
rs.Update
Next Order
'add products to tblOrdersProd
Set rs = db.OpenRecordset("tblOrdersProd", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
For Each OrderLine In Order("OrderLine")
rs.AddNew
rs!OrderDetailID = Order("OrderID")
arrValues = Split(OrderLine, ",")
For I = 0 To UBound(arrValues)
rs!Qty = arrValues(1)
rs!Productid = DLookup("ProductID", "tblProducts", "ProductCode = '" & OrderLine(arrValues(2)) & "'")
Next
rs.Update
Next OrderLine
Next Order
rs.Close
Here is my suggestion, you may need to adjust a bit to get it working...
Option Compare Database
Option Explicit
'//--------------------------
Dim db As DAO.Database
Dim rsOrderDetails As DAO.Recordset
Dim rsOrdersProd As DAO.Recordset
Dim JsonText As Object
Dim Order As Variant
Dim OrderLine As Variant
Dim newID as Long
'add order to tblOrderDetails
Set rsOrderDetails = db.OpenRecordset("tblOrderDetails", dbOpenDynaset, dbSeeChanges)
'add products to tblOrdersProd
Set rsOrdersProd = db.OpenRecordset("tblOrdersProd", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
With rsOrderDetails
.AddNew
!Date = Format(Now(), "dd/mm/yyyy")
!Time = Format(Now(), "hh:nn")
!ClientID = 123
!OrderNo = Order("OrderID")
!DelPhone = Order("ShipPhone")
!NotifyEmailAddress = Order("Email")
!DelName = Order("ShipCompany")
!DelStreet = Order("ShipStreetLine1")
!DelSuburb = Order("ShipCity")
!DelCity = Order("ShipState")
!DelZipCode = Order("ShipPostCode")
!DelCountryID = DLookup("CountryID", "tblCountries", "CountryCode = '" & Order("ShipCountry") & "'")
!DelContactName = Order("ShipFirstName") & " " & Order("ShipLastName")
.Update
'// Now get the newly-allocated autonumber field
.Bookmark = .LastModified
newID = !OrderDetailID
End With
For Each OrderLine In Order("OrderLine")
With rsOrdersProd
.AddNew
'// Use the ID from the OrderDetails record
!OrderDetailID = newID
!Qty = OrderLine("Quantity")
!Productid = DLookup("ProductID", "tblProducts", "ProductCode = '" & OrderLine("SKU") & "'")
.Update
End With
Next OrderLine
Next Order
rsOrderDetails.Close
rsOrdersProd.Close
I am running some code to split a slash-separated field into multiple rows, but the first value in the series is not carrying over. Does anyone know what I'm missing. Also, Rows that only have one record are not carrying over.
Public Sub ReformatTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsADD As DAO.Recordset
Dim strSQL As String
Dim strMPG, strBusinessName, strCustomerNumber, strCustomerName, strCountStartDate, strCCStatus As String
Dim strSplitMPG As String
Dim varData As Variant
Dim i As Integer
Set db = CurrentDb
' Select all eligible fields (have a comma) and unprocessed (SPLIT_MPG is Null)
strSQL = "SELECT BUSINESS_NAME, CUSTOMER_NUMBER, CUSTOMER_NAME, COUNT_START_DATE, CC_STATUS, MPG, SPLIT_MPG FROM [tmStarCycleCountStatuses_SlashesforCommas] WHERE ([MPG] Like ""*/*"") AND ([SPLIT_MPG] Is Null)"
Set rsADD = db.OpenRecordset("tmStarCycleCountStatuses_SlashesforCommas", dbOpenDynaset, dbAppendOnly)
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !MPG
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
strCustomerName = !CUSTOMER_NAME
strCountStartDate = !COUNT_START_DATE
strCCStatus = !CC_STATUS
varData = Split(strMPG, "/") ' Get all comma delimited fields
' Update First Record
.Edit
!SPLIT_MPG = Trim(varData(0)) ' remove spaces before writing new fields
.Update
' Add records with same first field
' and new fields for remaining data at end of string
For i = 1 To UBound(varData)
With rsADD
.AddNew
!MPG = strMPG
!SPLIT_MPG = Trim(varData(i)) ' remove spaces before writing new fields
!BUSINESS_NAME = strBusinessName
!CUSTOMER_NUMBER = strCustomerNumber
!CUSTOMER_NAME = strCustomerName
!COUNT_START_DATE = strCountStartDate
!CC_STATUS = strCCStatus
.Update
End With
Next
.MoveNext
Wend
.Close
rsADD.Close
End With
Set rsADD = Nothing
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I can't post images yet due to reputation constrictions, but here are some links.
Here's the multiple after the code:
https://s9.postimg.org/fn3u70b5b/Multiple.jpg
Here's the single records after code run:
https://s10.postimg.org/bfq9z4snt/Singles.jpg
I feel like there's something super simple that I'm missing here, but it looks like I'm already taking the MPG over, so i'm curious as to why I'm not getting the singles or the first of the series. Any help would be appreciated! Thank you.
It looks right to me, except that you have to declare like this:
Dim strMPG As String
Dim strBusinessNames As String
Dim strCustomerNumbers As String
Dim strCustomerNames As String
Dim strCountStartDates As String
Dim strCCStatus As String
I guess you will have to insert some lines with Debug.Print .. to narrow down the happenings.
Got it. Ended up changing my approach. This code will work. The pattern, regardless of length, would always be the same, so I used a Right/Left combo and integers
Public Sub ReformatmStarCycleCountStatusesTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strMPG As String
Dim strBusinessName As String
Dim strCustomerNumber As String
Dim strCustomerName As String
Dim dteCountStartDate As Date
Dim strCCStatus As String
Dim strSplitMPG As String
Dim intRemainingLength As Integer
Dim intInitialLength As Integer
Dim intStartPoint As Integer
Dim varData As Variant
Set db = CurrentDb
DoCmd.SetWarnings False
' Select all eligible fields (have a comma)
strSQL = "SELECT * FROM [mStar Cycle Count Statuses] WHERE [PRODUCT_FILTER_VALUE] is not null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !PRODUCT_FILTER_VALUE
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
dteCountStartDate = !COUNT_START_DATE
strCCStatus = !Status
intInitialLength = Len(strMPG)
intRemainingLength = intInitialLength
intStartPoint = 2
Do While intRemainingLength > 0
strSQL = "INSERT INTO tmStarCycleCountStatuses VALUES ('" & strBusinessName & "', '" & strCustomerNumber _
& "', #" & dteCountStartDate & "#, '" & strCCStatus & "', '" & Right(Left(strMPG, intStartPoint), 2) & "')"
DoCmd.RunSQL (strSQL)
intStartPoint = intStartPoint + 3
intRemainingLength = intRemainingLength - 3
Loop
intStartPoint = 1
.MoveNext
Wend
.Close
End With
DoCmd.SetWarnings True
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
Please forgive the sloppy coding, but I was thrown onto a project to get data from a spreadsheet to SQL server and the deadline has been missed. I was able to initial get my first dataswipe using a SELECT statement, but I can't seem to switch it over to an UPDATE.
Here's the code. I get the runtime error 3704 operation not allowed when object is closed at the line rstRecordset.AddNew
Public cnnConn As ADODB.Connection
Public rstRecordset As ADODB.Recordset
Public cmdCommand As ADODB.Command
Public Const Server As String = "datguy"
Public SQLQuery As String
Option Explicit
Sub testupinsertupdate()
Dim wkb As Workbook
Dim wks As Worksheet
Dim sel As Range
Set wkb = ActiveWorkbook
Set wks = Sheets(1)
Set sel = Selection
With wks
'Declaration unit
Dim dataitem As String
Dim yr As Integer
Dim yrmax As Integer
Dim rxcount As Integer
Dim row As Integer
Dim col As String
Dim cleanup As String
Dim sqlrxcount As String
dataitem = .Range("B3").Value
yr = 6 'data only needs to go back to 2006
yrmax = .Range("C7").End(xlToRight).row + yr 'declarative count to the Right-Of-File
rxcount = 7
row = .Range("A" & .Rows.Count).End(xlUp).row 'declarative count to EOF
col = .Range("C6").End(xlToRight).Column
cleanup = "Data Unavailable"
sqlrxcount = .Range("A" & rxcount).Value
Set cnnConn = New ADODB.Connection
cnnConn.ConnectionString = "driver={SQL Server};server=" & Server & ";database=database;Trusted_Connection=Yes"
cnnConn.ConnectionTimeout = 800
cnnConn.Open
For rxcount = 7 To row
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
.CommandTimeout = 0
.CommandText = "UPDATE table SET " & dataitem & " = '" & Cells(col).Value & "' WHERE RX_ID = '" & sqlrxcount & "'"
.CommandType = adCmdText
.Execute
Debug.Print cmdCommand.State
End With
Debug.Print cmdCommand.State
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
col = ("C" & rxcount)
For yr = 6 To yrmax
rstRecordset.AddNew '*** error pops!
rstRecordset.Fields("RX_ID") = Range("A" & rxcount).Value
rstRecordset.Fields("YEAR_REPORTED") = yr + 2000
If Range(col).Value = cleanup Then
rstRecordset.Fields(dataitem) = Null
Else: rstRecordset.Fields(dataitem) = Range(col).Value
End If
'debug line to show results
Debug.Print Range("A" & rxcount).Value, yr + 2000, Range(col).Value
col = Range(col).Offset(0, 1).Address
Next yr
Next rxcount
rstRecordset.UpdateBatch
rstRecordset.Close
cnnConn.Close
End With
End Sub
I don't feel like I'm doing the operations in order, but I'm just trying to get the initial load and then will worry about maintenance later. Why isn't the object(I assume this is the recordset) open when it was opened three lines before?
You are attempting to open a recordset based on an update not a select
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
should be something like
rstRecordset.Open "select * from table",cnnconn, adOpenStatic, adLockBatchOptimistic
Example:
I have the excel file test.xls and in it the sheet1, sheet2, sheet3, sheet4 with some information in it.
I want to export the result of 4 queries to those sheets, but I want to add the result after the last row with data and not to overwrite it.
I worked on something similar recently. In Excel I used VBA.
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
Dim StartDate As Date, EndDate As Date, ModStartDate As Date, ModEndDate As Date
'Modify the Start date because Maint 24hr cycle is 930 - 930 not 12 - 12
ModStartDate = StartDate - 1
''Access database
strFile = "S:\IT\Databases\Main_BE.mdb"
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
'Get the info from Access
strSQL = "SELECT * FROM Work_Orders " _
& "WHERE Repair_Start_Date >= #" & ModStartDate & "# " _
& "AND Repair_Start_Date <= #" & EndDate & "# " _
& "ORDER BY Repair_Start_Date, Repair_Start_Time"
rs.Open strSQL, cn
'Paste the SQL query at A10 Sheet3
Sheet3.Cells(10, 1).CopyFromRecordset rs
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
You would just need to modify the SQL statement, and then to add a new row you could use a variable to count the number of existing rows with:
"=Counta(some range:some range)"
Then just add 1 to the variable for the next row.
Thanks everybody!
I could solve it using :
Private Sub Command0_Click()
Dim rstName As Recordset
Set rstName = CurrentDb.OpenRecordset("query1")
Dim objApp As Object, objMyWorkbook As Object, objMySheet As Object, objMyRange As Object
Set objApp = CreateObject("Excel.Application")
Set objMyWorkbook = objApp.Workbooks.Open("c:/exportarexcell/teste.xls")
Set objMySheet = objMyWorkbook.Worksheets("FolhaTeste")
Set objMyRange = objMySheet.Cells(objApp.ActiveSheet.UsedRange.Rows.Count + 1, 1)
With objMyRange
rstName.MoveFirst 'Rewind to the first record
.Clear
.CopyFromRecordset rstName
End With
End Sub