I'm developing an Access database and have some code on a form button that takes the contents of a recordset and exports it to an excel document. The following code works however I have been asked that the export data be reversed on the worksheet.
Set qdef = db.QueryDefs("Inspection_Detail_Crosstab")
qdef![Tag_No_Param] = Tag_Number.Value
Set rs = qdef.OpenRecordset()
EquipmentCellSt = (Col & EquipmentCell)
With wsheet
.Range(EquipmentCellSt).CopyFromRecordset rs
End With
So rather than(as it does right now):
- item 1
- item 2
- item 3
it exports:
- item 3
- item 2
- item 1
I thought a method of doing this would be to:
With wsheet
rs.MoveLast
.Range(EquipmentCellSt).CopyFromRecordset rs
rs.MovePrevious
End With
But adding the MoveLast and MovePrevious just seems to lock up the program.
You can manually export the recordset by iterating through the records in reverse:
Dim rowNum as Long
Dim columnNum As Long
Dim fld As Field
columnNum = 0
rowNum = 0
'stupid client-side sorting, because management
rs.MoveLast
Do While Not rs.BOF
For Each fld In rs.Fields
wsheet.Range(EquipmentCellSt).Offset(rowNum, columnNum).Value = fld.Value
columnNum = columnNum + 1
Next
rowNum = rowNum + 1
columnNum = 0
rs.MovePrevious
Loop
Related
I am trying to use recordset code to loop through all the fields in a table and debug.print their values and field names in an order you would naturally read the table ie from left to right across columns then onto the row below
I have accomplished what I'm trying to do but only for the first row. This is the code:
Sub RecordSets()
Dim db As Database
Dim rs As Recordset
Dim i As Long
Set db = CurrentDb
Set rs = db.OpenRecordset("tbl1")
For i = 0 To rs.Fields.Count - 1
Debug.Print rs.Fields(i).Name
Debug.Print rs.Fields(i).Value
Next
rs.Close
db.Close
End Sub
Immediate window produces following result:
Category
Clothing
Item
Shirt
Price
5
This is the top row and is exactly as I want. But I cannot get any code to work accomplish this exact same thing for the other rows. I am 99% sure I need to use a Do Until .EOF loop in conjunction with the For...Next loop but I can't get the results whatever I try or I lock access up in an infinite query.
Thanks for your help
Untested:
Sub RecordSets()
Const SEP as String = vbTab
Dim db As Database
Dim rs As Recordset, numFlds As Long
Dim i As Long, s As String, sp as string
Set db = CurrentDb
Set rs = db.OpenRecordset("tbl1")
numFlds = rs.Fields.Count
'print the headers (field names)
For i = 0 To numFlds - 1
s = s & sp & rs.Fields(i).Name
sp = SEP '<< add separator for subsequent items
Next
Debug.Print s
'print the data
sp = "" '<< clear the separator
Do While Not rs.EOF
For i = 0 To numFlds - 1
s = s & sp & rs.Fields(i).Name
sp = SEP
Next
Debug.Print s
rs.MoveNext
Loop
rs.Close
db.Close
End Sub
I have a form named frmPUCFinalize with four buttons named btn1,btn1,btn2,btn4 and also have a table (tblStatus) where 4 caption name are stored in single field named "Button".
I want to replace all 4 buttons captions of frmPUCFinalize with each recordset from table field (Field Name : Button) using loop or other method.
I tried following code but couldn't succeed.
Private Sub Form_Load()
Dim rst As Recordset
Dim mSQL As String
mSQL = "SELECT tblStatus.Button FROM tblStatus WHERE (((tblStatus.RoleID)=4) AND ((tblStatus.Form)='frmPUCFinalize')) ORDER BY tblStatus.Button;"
Set rst = CurrentDb.OpenRecordset(mSQL)
x = 1
Y = 4 'maximun 4 buttons
rst.MoveFirst
Do While (rst.BOF = False And rst.EOF = False) And x < Y + 1
Me("btn" & x).Caption = rst!Button
x = x + 1
rst.MoveNext
Loop
rst.Close
End Sub
Try this:
Private Sub Form_Load()
Dim rst As Recordset
Dim mSQL As String
Dim idx As Long
mSQL = "SELECT tblStatus.Button FROM tblStatus WHERE (((tblStatus.RoleID)=4) AND ((tblStatus.Form)='frmPUCFinalize')) ORDER BY tblStatus.Button;"
Set rst = CurrentDb.OpenRecordset(mSQL)
If rst.EOF Then
rst.Close
Exit Sub
End If
With rst
.MoveLast
.MoveFirst
End With
For idx = 1 to rst.RecordCount
Me.Controls("btn" & idx).Caption = rst![Button]
rst.MoveNext
Next idx
rst.Close
End Sub
I'm currently running a SQL stored procedure from an Excel Macro. The count of returned records exceeds the maximum rows for one sheet. How can I transfer the overflow results to a second sheet?
Sub Button1_Click()
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim par As String
Dim WSP1 As Worksheet
Set con = New ADODB.Connection
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Application.DisplayStatusBar = True
Application.StatusBar = "Contacting SQL Server..."
' Remove any values in the cells where we
' want to put our Stored Procedure's results.
Dim rngRange As Range
Set rngRange = Range(Cells(8, 2), Cells(Rows.Count, 1)).EntireRow
rngRange.ClearContents
' Log into our SQL Server, and run the Stored Procedure
con.Open "Provider=SQLOLEDB;Data Source=67.09;Initial Catalog=TEST..."
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandText = "SP_Billing"
Set rs = cmd.Execute(, , adCmdStoredProc)
' Copy the results to cell B7 on the first Worksheet
Set WSP1 = Worksheets(1)
WSP1.Activate
If rs.EOF = False Then WSP1.Cells(8, 2).CopyFromRecordset rs
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
Application.StatusBar = "Data successfully updated."
End Sub
Just pass the MaxRows parameter to .CopyFromRecordset and loop until you hit EOF. Each call advances the cursor in the recordset, and the copy starts from the current cursor location. I'd extract it to a Sub something like...
Private Sub SplitRecordsToSheets(records As ADODB.Recordset, perSheet As Long)
Dim ws As Worksheet
Do While Not records.EOF
Set ws = Worksheets.Add
ws.Cells(8, 2).CopyFromRecordset records, perSheet
Loop
End Sub
...and then call it like this:
' Log into our SQL Server, and run the Stored Procedure
con.Open "Provider=SQLOLEDB;Data Source=67.09;Initial Catalog=TEST..."
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandText = "SP_Billing"
Set rs = cmd.Execute(, , adCmdStoredProc)
SplitRecordsToSheets rs, ActiveSheet.Rows.Count - 8
If you require some custom handling while parsing through your RecordSet (such as switching pages once you have printed, say 100k rows), you can no longer use the Range.CopyFromRecordset method. Instead, you may have to iterate through the recordset yourself. Here is a small sample of how to do such a thing (without giving the whole puzzle away, of course:
Dim i_RowCount As Long
Dim a_PrintArray As Variant, rg_PrintRg As Range
Dim i_Col As Integer
Const i_MaxRows As Long = 100000
' I recommend filling everything into an Array first and then Printing the array to Excel'
' Using your existing variables also '
ReDim a_PrintArray( 1 to i_MaxRows, 1 to rs.Fields.Count )
Set sh_Current = WSP1
Do Until rs.EOF
i_RowCount = i_RowCount + 1
If i_RowCount > i_MaxRows Then 'If we hit the max, print what we have'
' Setting up the print range to match the array size '
Set rg_PrintRg = shCurrent.Cells(8, 2)
Set rg_PrintRg = Range(rg_PrintRg, rg_PrintRg.Offset(i_MaxRows - 1, rs.Fields.Count - 1))
rg_PrintRg = a_PrintArray ' Print the array into the range '
i_RowCount = 1
Set sh_Current = sh_Current.Next
ReDim a_PrintArray( 1 to i_MaxRows, 1 to rs.Fields.Count )
End If
For i_Col = 0 To rs.Fields.Count - 1
a_PrintArray(i_RowCount, i_Col) = rs.Fields(i_Col).Value
Next i_Col
rs.MoveNext
Loop
Please note this code snippit is for demonstration only. It has not been compiled and may not be optimal for your specific application. For more information on the Recordset object: https://msdn.microsoft.com/en-us/library/ms681510%28v=vs.85%29.aspx
I have an access database with vba code that is attempting to access an excel sheet and copy the data to a recordset using DAO.recordset. If all of the column (assocId) is integer the import works wonderfully if all are strings it works but if you have a mixed back (eg 111111 | Vinny | etc and then on row two you have JOE-1 | Joe | etc) the import will fail. It says "You cannot record your changes because a value you entered violates the settings defined for this table"
Here is the offending sub:
Public Sub LoadFileInfo()
'Load information from selected file
On Error GoTo ErrorHappened
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim i As Integer
Dim lastTransType As String
Dim transactionCounter As Integer
Dim currentRecord As CurrentImportRecord
Dim wtf As Variant
Set db = CurrentDb()
Set rs = db.OpenRecordset(selectTransTypesSql & GetSetting("PayrollManualImportExportTransactionTypes") & ")")
ReDim transTypes(DCount("TransType", "MasterTransactionTypes", "IsActive <> 0")) As MasterTransactionTypes
rs.MoveFirst
Do While Not rs.EOF
'Add each transaction type and desc to the Private Type and increment the appropriate counter
GetMasterTransactionTypes rs!TransType, rs!TransDesc, i
rs.MoveNext
i = i + 1
Loop
rs.Close
Set db = OpenDatabase(importFileName, False, True, "Excel 12.0;HDR=Yes")
Set rs = db.OpenRecordset("SELECT * FROM " & "[" & GetSheetName(importFileName) & "$]" & " ORDER BY TransType")
rs.MoveLast
importFields = vbNullString
For i = 0 To rs.Fields.count - 1
importFields = importFields & rs.Fields(i).Name & ","
Next
fullImport = (rs.Fields.count > 4)
i = 0
transactionCounter = 1
lblFile.Caption = "File name: " & importFileName
Dim rowNum As Variant
rowNum = rs.RecordCount
wtf = rs.GetRows(rowNum)
ReDim ledgerEntries(rs.RecordCount) As PayrollLedgerImport
'Check to see if the recordset actually contains rows; if so push transaction objects to private type array
rs.MoveFirst
Do While Not rs.EOF
currentRecord.associateId = CStr(rs!assocId)
currentRecord.transactionType = rs!TransType
currentRecord.transactionNotes = CStr(rs!TransNotes)
If lastTransType = CStr(currentRecord.transactionType) Then
transactionCounter = transactionCounter + 1
Else
transactionCounter = 1
End If
If IsValidTransType(currentRecord.transactionType) Then
If Not fullImport Then
currentRecord.transactionAmount = rs!TransAmount
GetPayrollTransactions currentRecord.associateId, currentRecord.transactionType, currentRecord.transactionAmount, currentRecord.transactionNotes, i, transactionCounter
Else
currentRecord.transactionAmount = rs!TransAmt
GetPayrollTransactions currentRecord.associateId, currentRecord.transactionType, currentRecord.transactionAmount, currentRecord.transactionNotes, i, transactionCounter
End If
Else
MsgBox (currentRecord.transactionType & ": Not A Valid Transaction Type")
End If
lastTransType = rs!TransType
rs.MoveNext
i = i + 1
Loop
FormatFileInformationWindow
cmdImportFile.Enabled = True
End Sub
I've been at this for hours. I've tried casting all the columns when I take them in and I get the same issue. Works fine for all ints or all strings but in reality some of our employees have string and some have int for employee ID. I tried taking them all in as string converting where necessary but that didn't work either. Only thing that works is two sheets - one containing strings one containing ints.
I have a table that roughly looks like this:
the 1300 and 850 stand for frequency on wich these fibre cables are checked
The real problem is that the 1300 and 850 aren't set values. In a different file they could be "100" and "320", so I can't just look for "850" or "1300" to seperate the entries.
There are a few things that I can be sure of:
There's always 2 different frequencies (let's call them "A" and "B" from now on)
There are always the same amount of "A" entries as there are "B" entries
the string is always a variations of \<A>\<A>nm_<LocationName>_<CoreNumber>.SOR
What I would like to have is 2 seperate tables, 1 for all of the "A" entries and one for the "B" entries.
How can I do this?
It doesn't matter if I have to use SQL or VBA
Edit:
By looking around on the internet, I have gained a general idea of how I would like this to work:
open the table as a recordset.
search every line for the value between the \'s. Example: \<value>\
for every new value between the \ \
fill the first table with all entries that have the first value (in our example 1300)
I just have no clue how to translate this into code, the person that knows how to do this, easy points
So I may have made is sound way easier and bit off more than I could chew, but I was able to create something that works on my MS Access with a sample Database. I did all this from just quick Google-fu so it may not be as elegant as an expert. But it works. This only takes the existing table and creates new tables, but if you need help transferring data then I can tweak this.
Dim myR As Recordset
Dim strSQL As String
Dim strMOD As String
Dim strFULL As String
Dim strNEW As String
Dim charPOS As Integer
Dim strLEN As Integer
Dim strTABLES() As Variant
Dim dbs As DAO.Database
Dim tdfloop As DAO.TableDef
Dim i As Long
Dim j As Long
Dim strNAME As String
Dim alrEXIST As Boolean
i = 0
Set dbs = CurrentDb
With dbs
For Each tdfloop In .TableDefs
ReDim Preserve strTABLES(0 To i)
strTABLES(UBound(strTABLES)) = tdfloop.Name
i = i + 1
Next tdfloop
End With
Set dbs = Nothing
'select all the rows in your table so we can add them to recordset
strSQL = "SELECT * FROM Files"
'create your recordset
Set myR = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
'now to access each row we use a loop
'if you're not sure the field names, you can access them like this:
'myR.Fields(1).Value
'or if you do know the field name then this
'myR![Filename]
myR.MoveFirst 'This just makes sure you're starting from the first record
Do Until myR.EOF = True
strFULL = myR![FileName] 'set this to string so it can be worked with
strLEN = Len(strFULL) 'gets the length of the string aka filename
strMOD = Right(strFULL, strLEN - 1) 'removes the first \
charPOS = InStr(strMOD, "\") 'gets the positiong of the next \
strNEW = Mid(strMOD, 1, charPOS - 1) 'gets the substring from left to \
'use this to check and see if the name is a table already
For j = 0 To i - 1
If strNEW = strTABLES(j) Then
alrEXIST = True 'boolean created for if table exists
End If
Next
'if not a table, create a table
If alrEXIST = False Then
DoCmd.RunSQL "CREATE TABLE " & strNEW & " ([Field1] text(255), [Field2] text(255))"
End If
alrEXIST = False 'reset value to false
myR.MoveNext 'Move to the next record before restarting the loop
Loop
Set myR = Nothing
Thanks to TKEyi60's answer, I was put on the right track. Had to tweak the code here and there to come to this solution:
Public Function SplitTable()
Dim SQL As String
Dim strMOD As String
Dim strFULL As String
Dim strNEW As String
Dim charPOS As Integer
Dim strLEN As Integer
Dim i As Long
Dim j As Long
Dim alrEXIST As Boolean
Dim strTABLES() As Variant
Dim Rcst As DAO.Recordset
Dim dbs As DAO.Database
Dim tdfloop As DAO.TableDef
i = 0
Set dbs = CurrentDb
For Each tdfloop In dbs.TableDefs
ReDim Preserve strTABLES(0 To i)
strTABLES(UBound(strTABLES)) = tdfloop.Name
i = i + 1
Next tdfloop
Set dbs = Nothing
'Select all the rows in the table so they can be added to a Recordset
SQL = " SELECT * FROM tblTotaalVerlies"
Set Rcst = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)
Rcst.MoveFirst
Do Until Rcst.EOF = True
strFULL = Rcst![FileName] 'set this to string so it can be worked with
strLEN = Len(strFULL) 'gets the length of the filename
strMOD = Right(strFULL, strLEN - 1) 'removes the first \
charPOS = InStr(strMOD, "\") 'gets the positiong of the next \
strNEW = Mid(strMOD, 1, charPOS - 1)
'use this to check and see if the name is a table already
For j = 0 To i - 1
If strNEW = strTABLES(j) Then
alrEXIST = True 'boolean created for if table exists
End If
Next j
'if not a table, create a table
If alrEXIST = False Then
DoCmd.RunSQL "CREATE TABLE " & strNEW & " ([Filename] varchar(32), [Verlies] varchar(32))"
'Renew tabledef array
i = i + 1
ReDim Preserve strTABLES(0 To i - 1)
strTABLES(UBound(strTABLES)) = strNEW
End If
alrEXIST = False 'reset value to false
Rcst.MoveNext 'Move to the next record before restarting the loop
Loop
Set Rcst = Nothing
End Function