I am trying to do a dlookup where the criteria should be the current recordset and the textbox number (eg text13) should update to the next textbox number (eg text14):
'Count MasterList Items
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsCount As Integer
Dim queryNameOrSQL As String
queryNameOrSQL = "qryMasterList"
Set db = CurrentDb
Set rs = db.OpenRecordset(queryNameOrSQL)
rsCount = rs.RecordCount
i = 1
textBoxIndex = 13
Do While i <= rsCount
Me.Text & textBoxIndex = DLookup("[Item]", "MasterList", "WHERE RECORDSET = " & i)
i = i + 1
textBoxIndex = textBoxIndex + 1
Loop
There is no need to count the records - just loop along:
Const textBoxIndex As Long = 12
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim queryNameOrSQL As String
Dim recorditem As Long
queryNameOrSQL = "qryMasterList"
Set db = CurrentDb
Set rs = db.OpenRecordset(queryNameOrSQL)
While Not rs.EOF
recorditem = recorditem + 1
Me("Text" & CStr(textBoxIndex + recorditem) & "").Value = DLookup("[Item]", "MasterList", "WHERE RECORDSET = " & recorditem & "")
rs.MoveNext
Wend
rs.Close
Related
I am trying to write SQL Server data to an Excel sheet but it is very slow. Is there something to optimize? Approximately, 4000 entries at 20 cColumns takes 6-7 minutes.
Database ("freigabe") Module: Connecting to Database and get RecordSet
(this works like a charm)
Private Function ConnectSQL() As ADODB.Connection
Set conn = New ADODB.Connection
conn.ConnectionString = "DRIVER={SQL Server};" _
& "SERVER=xxxxx;" _
& " DATABASE=xxxxx;" _
& "UID=xxxxxx;PWD=xxxxx; OPTION=3"
conn.Open
Set ConnectSQL = conn
End Function
Public Function load(Optional ByVal FieldName As String = "", Optional ByVal fieldValue As String = "", Optional ByVal ComparisonOperator As String = "=")
'wenn fehler return?
'-> Über errorhandler retun rs oder boolen
Dim rs As New ADODB.Recordset
Dim sql As String
Dim contition As String
contition = " "
Dim sqlfrom As String
Dim sqlto As String
On Error GoTo Fehler:
sql = "SELECT * FROM " & TBLNAME & " WHERE storno='0' AND created BETWEEN '2020-02-01' AND '2020-02-15'"
Set conn = ConnectSQL()
rs.Open sql, conn, adOpenStatic
Set load = rs
Exit Function
End If
Fehler:
load = Err.Description
End Function
Get/Write: Build a connection and retrieving recordset. The While loop is taking long. I am skipping text-rich columns (it gets faster but still too long). Showing a load-window so the person doesn't think that Excel "isn't working". After that, the data get's validated (not included).
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rs As Recordset
Dim k As Integer
Dim i As Integer
Dim startt As Double
Dim endt As Double
Dim rngDst As Range
Set rs = freigabe.load()
Set rngDst = Worksheets("Freigaben").Range("G2")
With Worksheets("Freigaben").Range("g2:Z50000")
.ClearContents
'.CopyFromRecordset rs
End With
Count = rs.RecordCount
k = 0
gui_laden.Show
startt = Timer
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While Not .EOF
For i = 0 To .Fields.Count - 1
If i <> 13 And i <> 2 And i <> 10 And i <> 5 And i <> 6 And i <> 0 Then rngDst.Offset(, i) = .Fields(i).Value 'skip unneccessary data and write
Next i
k = k + 1
Debug.Print k & "/" & Count
gui_laden.lbl_status = "Lade Daten herunter: " & k & "/" & Count
gui_laden.Repaint
.MoveNext
DoEvents 'Ensure Application doesn't freeze
Set rngDst = rngDst.Offset(1)
Wend
End If
End With
endt = Timer - startt
Debug.Print "Dauer: " & endt
What I tried:
CopyFromRecordSet -> Application freezes
Test in new workbook -> same
Thank you very much!
I am trying to add a record on the main table whenever I click submit and one field from this table will go to another one of two tables as a new row based on whether i check a checkbox. For some reason, the record only goes into the main table and neither of the other two. Here's my code.
Private Sub Submit_Click()
Dim SqlString As String
Dim rs As DAO.Recordset
Dim req As Integer
SqlString = "SELECT * FROM [WorkRecord]"
SqlString1 = "SELECT * FROM [MainWork]"
sqlString2 = "SELECT * FROM [MiscelleneousWork]"
Set db = CurrentDb
Set rs = db.OpenRecordset(SqlString)
rs.MoveLast
lastnum = rs!WorkNum
rs.AddNew
rs!WorkNum = lastnum + 1
rs!WorkDate = Me.WorkDate.Value
rs!ReqNum = Me.ReqNum.Value
rs.Update
If Me.checkmain.Value = True Then
Set rs1 = db.OpenRecordset(SqlString1)
rs1.MoveLast
lastnum = rs!WorkNum
rs1.AddNew
rs1!WorkNum = lastnum + 1
rs1.Update
rs1.Close
Else
Set rs2 = db.OpenRecordset(sqlString2)
rs2.MoveLast
lastnum = rs!WorkNum
rs2.AddNew
rs2!WorkNum = lastnum + 1
rs2.Update
rs2.Close
End If
MsgBox ("Work added.")
DoCmd.Close acForm, "AddWorkRecord"
rs.Close
End Sub
I have two tables, ID table and Mastertable. In ID table i have level and activity which is given a start number, let us say 1000. In Mastertable i have many drawings associated to the same activity and level. I have to provide numbering to them starting from the ID table value 1000 and increment it by 1. After finishing, the max value from the mastertable has to be replugged to ID table.
Also, if there is Level and Activity, the ID has to be picked looking up for level and activity both, if no level is mentioned then it has to only lookup activity.
I tried a lot but could not succeed.
I used the Code below, but it looks up only Activity and not level. Also it does not go back to id table and update the max ID from the master Table.
Option Compare Database
Option Explicit
Public Function SequenceNew()
Dim strSQL As String
Dim db As Database
Dim rs As DAO.Recordset
Dim a, initNo As Integer
Dim b As Integer
strSQL = "SELECT * FROM MasterTable ORDER BY LevelID"
'Set db = CurrentDb
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
rs.Edit
If rs![DrawingTypeName] = "Concrete" And rs![ProjectName] = Forms!frm_Publish!CboProject And rs!IDGiven = "Not Given" Then
a = a + 1
rs!Sequence = DLookup("CONCRETE", "Qry_ID_Selected") + a
ElseIf rs![DrawingTypeName] = "Reinforcement" And rs![ProjectName] = Forms!frm_Publish!CboProject And rs!IDGiven = "Not Given" Then
b = b + 1
rs!Sequence = DLookup("REINFORCEMENT", "Qry_ID_Selected") + b
ElseIf rs![DrawingTypeName] = "Steel structural works" And rs![ProjectName] = Forms!frm_Publish!CboProject And rs!IDGiven = "Not Given" Then
End If
rs.Update
rs.MoveNext
Loop
rs.Close
Set db = Nothing
Else
MsgBox " No records Found"
rs.Close
Set db = Nothing
End If
End Function
There should be some other better way to do it.
MasterTable
ID Table
the issue is Resolved by the new code i could work out.
Option Compare Database
Option Explicit
Public Function SequenceNewLevel()
Dim strSQL As String
Dim strSQL1 As String
Dim db As Database
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset2
Dim a, initNo As Integer
a = 0
strSQL = "SELECT * FROM MasterTable"
strSQL1 = "SELECT * FROM ID"
Set db = CurrentDb
Set rs1 = CurrentDb.OpenRecordset(strSQL1)
If rs1.RecordCount > 0 Then
rs1.MoveFirst
Do While Not rs1.EOF
rs1.Edit
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
rs.Edit
If rs![TypeOfDrawing] = rs1![Activity] And rs![Project] = rs1![Project] And rs![LevelName] = rs1![Level] And rs![IDGiven] = "Not Given" Then
a = a + 1
rs!Sequence = rs1!StartID + a
rs1!StartID = rs!Sequence
a = 0
rs![IDGiven] = "GIVEN"
End If
rs.Update
rs.MoveNext
Loop
End If
rs1.Update
rs1.MoveNext
Loop
rs1.Close
rs.Close
Set db = Nothing
Else
MsgBox " No records Found"
rs.Close
Set db = Nothing
End If
End Function
Public Function SequenceNewWithOutLevel()
Dim strSQL As String
Dim strSQL1 As String
Dim db As Database
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset2
Dim a, initNo As Integer
a = 0
strSQL = "SELECT * FROM MasterTable"
strSQL1 = "SELECT * FROM IDWithoutlevel"
Set db = CurrentDb
Set rs1 = CurrentDb.OpenRecordset(strSQL1)
If rs1.RecordCount > 0 Then
rs1.MoveFirst
Do While Not rs1.EOF
rs1.Edit
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
rs.Edit
If rs![TypeOfDrawing] = rs1![Activity] And rs![Project] = rs1![Project] And rs![IDGiven] = "Not Given" Then
a = a + 1
rs!Sequence = rs1!StartID + a
rs1!StartID = rs!Sequence
a = 0
rs![IDGiven] = "GIVEN"
End If
rs.Update
rs.MoveNext
Loop
End If
rs1.Update
rs1.MoveNext
Loop
rs1.Close
rs.Close
Set db = Nothing
Else
MsgBox " No records Found"
rs.Close
Set db = Nothing
End If
End Function
So I have fixed my initial problem. However, now my data isn't actually updated by the data in the excel file. Instead, the #temp table never takes on the value of the excel file but keeps the original data that is inputted. How do I make sure the data is coming from the excel file? Right now I am inputting the data from the original table just purely to keep the structure. Then I want to replace that with the new data on the temp table. Then replace the data on the table with the temp table data.
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
Dim beforeSQL As String
With CN
.Execute " Select * Into #temp1 from dim.DepartmentLeader"
End With
Dim level As Long
level = CN.BeginTrans
cmd.CommandType = 1 ' adCmdText
' Dim rst As ADODB.Recordset
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
With rst
Set .ActiveConnection = CN
.Source = "SELECT * FROM #temp1"
.CursorLocation = 3 ' adUseClient
.LockType = 4 ' adLockBatchOptimistic
.CursorType = 0 ' adOpenForwardOnly
.Open
' Column mappings
Dim tableFields(8) As Integer
Dim rangeFields(1000) As Integer
Dim exportFieldsCount As Integer
exportFieldsCount = 0
Dim col As Integer
Dim index As Integer
Dim lastRow As String
Dim copyRange As String
lastRow = LastRowInOneColumn()
For col = 0 To .Fields.Count - 1
index = Application.Match(.Fields.Item(col).Name, Range("A1:H249").Rows(1), 0)
If index > 0 Then
exportFieldsCount = exportFieldsCount + 1
tableFields(exportFieldsCount) = col
rangeFields(exportFieldsCount) = index
End If
Next
If exportFieldsCount = 0 Then
ExportRangeToSQL = 1
GoTo ConnectionEnd
End If
' Fast read of Excel range values to an array
' for further fast work with the array
Dim arr As Variant
arr = Range(Cells(1, 13).Value).Value
' The range data transfer to the Recordset
Dim row As Long
Dim rowCount As Long
rowCount = UBound(arr, 1)
Dim val As Variant
For row = 2 To rowCount
.AddNew
For col = 1 To exportFieldsCount
val = arr(row, rangeFields(col))
Debug.Print row
If IsEmpty(val) Then
Else
.Fields(tableFields(col)) = val
End If
Next
Next
.UpdateBatch
End With
With CN
.Execute "update dim.DepartmentLeader set " & _
"AUDescriptions = #temp1.AUDescriptions, " & _
"Dim.DepartmentLeader.Status = #temp1.Status, " & _
"dim.DepartmentLeader.Pillar = #temp1.Pillar," & _
"dim.DepartmentLeader.L1 = #temp1.L1, " & _
"dim.DepartmentLeader.L2 = #temp1.L2," & _
"dim.DepartmentLeader.L3 = #temp1.L3," & _
"dim.DepartmentLeader.L4 = #temp1.L4 " & _
"FROM dim.DepartmentLeader Inner Join #temp1 On dim.DepartmentLeader.DepartmentNumber= #temp1.DepartmentNumber " & _
"WHERE dim.DepartmentLeader.DepartmentNumber = #temp1.DepartmentNumber " & _
"IF ##ROWCOUNT = 0 " & _
"insert into dim.DepartmentLeader (dim.DepartmentLeader.DepartmentNumber, dim.DepartmentLeader.AUDescriptions, dim.DepartmentLeader.Status, dim.DepartmentLeader.Pillar,dim.DepartmentLeader.L1, dim.DepartmentLeader.L2,dim.DepartmentLeader.L3,dim.DepartmentLeader.L4)" & _
" SELECT * FROM #temp1 "
End With
rst.Close
Set rst = Nothing
ConnectionEnd:
CN.CommitTrans
You are using UpdateBatch with a adOpenForwardOnly cursor. You should only be using UpdateBatch with a Keyset or Static cursor only. See this MSDN article for more information: https://msdn.microsoft.com/en-us/library/windows/desktop/ms675283(v=vs.85).aspx
With rst
Set .ActiveConnection = cn
.Source = "SELECT * FROM ##temp1"
.CursorLocation = 3 ' adUseClient
.LockType = 4 ' adLockBatchOptimistic
'Use a Keyset cursor in prep for using UpdateBatch
.CursorType = 1 ' adOpenKeyset
......
......
End With
Alternatively, you could consider using rst.Update for each individual recordset in the loop.
I've been developing a little tool that query's our database and returns some references.
I'm having a problem adding the newly query'd values below already existing values in the excel Sheet1.
Option Explicit
Public Ref As String
Const DWConnectString = "Provider=SQLOLEDB... "
Public Property Get rRef() As String
rRef = Me.TextBox1.Value
Ref = Trim(rRef)
End Property
Private Sub TextBox1_Change()
Dim rRef As String
rRef = Me.TextBox1.Value
End Sub
Private Sub ZoekRef_Click()
Dim cn As Object
Dim rs As Object
Dim cm As Object
Dim Ref As String
Dim StrSource As String
Dim startrow As Integer
Ref = rRef
Set cn = CreateObject("ADODB.Connection")
cn.Open DWConnectString
Set rs = CreateObject("ADODB.Recordset")
'rs = New ADODB.Recordset
StrSource = "Select CONSIGNMENT.CONSIGNMENT, CONSIGNMENT.DOCUMENT_REMARK_2, INVOICE_HIST.NET_AMOUNT, INVOICE_HIST.VAT_AMOUNT, INVOICE_HIST.INV_CURRENCY "
StrSource = StrSource & "from CONSIGNMENT left outer join INVOICE_HIST ON CONSIGNMENT.CONSIGNMENT=INVOICE_HIST.CONSIGNMENT "
StrSource = StrSource & "where DOCUMENT_REMARK_2 like '%"
StrSource = StrSource & Ref & "%'"
rs.Open StrSource, cn
If rs.EOF Then
MsgBox "Geen Resultaten"
Exit Sub
Else
Dim fieldNames, j
rs.MoveFirst
ReDim fieldNames(rs.Fields.Count - 1)
For j = 0 To rs.Fields.Count - 1
fieldNames(j) = rs.Fields(j).Name
Next
Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(1, rs.Fields.Count)).Value = fieldNames
For j = 1 To rs.Fields.Count
Sheet1.Columns(j).AutoFit
Next
Sheet1.Cells.CopyFromRecordset rs
'fldcount2 = Sheets("sheet1").UsedRange.Rows.Count
Sheet1.Rows(1).Insert
Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(1, rs.Fields.Count)).Value = fieldNames
startrow = 3
Do Until rs.EOF
rs.MoveNext
startrow = startrow + 1
Loop
End If
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I thought about using the line:
Do until trim(cells(startrow,1).Value) = ""
startrow = startrow + 1
Loop
Before the rs.Movenext lines, but that seems to test the recordset, not the actual excel file.
Can I test my current Sheet1's values before adding the new recordset so it comes below what's already existing?
Thanks for the help.
Expand the scope of your loop.
rs.MoveFirst
Do Until rs.EOF
'Do all your work here
'Then increment your counter and the recordset
rs.MoveNext
startrow = startrow + 1
Loop