Good day,
I am trying to transpose the values added to my listbox via a query. Also does anyone have tips on how to get the column names on the Column Header. This is what the values in my listbox looks like:
Below is my code thus far:
Dim conn As New ADODB.Connection
Dim reCs As ADODB.Recordset
Dim tarSheet As Worksheet
Dim strbooK As String, strTar As String
Dim arTar As Range
strbooK = ThisWorkbook.Path & "\Excel_VBA.xlsm"
If opTar.Value = True Then
strTar = "SELECT TargetNumber as [Target Number] " & _
",TargetName as [Target Name] " & _
",TargetPrefix as [Target Nickname] " & _
",Count(TargetNumber) as [Number of Events] " & _
"FROM [Master$] " & _
"GROUP BY TargetNumber, TargetName, TargetPrefix " & _
"HAVING TargetNumber = '" & txt_search.Value & "';"
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strbooK & ";" & _
"Extended Properties='Excel 12.0 Xml;HDR=YES';"
conn.Open
Set reCs = New ADODB.Recordset
reCs.ActiveConnection = conn
reCs.Source = strTar
reCs.Open
With lbx_reCs
.BoundColumn = 1
.ColumnCount = 4
.ColumnHeads = True
.TextAlign = fmTextAlignCenter
.ColumnWidths = "136;136;136;136;"
.MultiSelect = fmMultiSelectMulti
' .RowSource = arTar.Address
.List() = reCs.GetRows
End With
'Releasing Objects
reCs.Close
conn.Close
End If
Thank you
As said in the titel you need no transpose of the values of the recordset, just use the column property of the listbox.
.Column = reCs.GetRows
For the other question you might look here. That seems not to be possible in case you have an array like in this case. On the other hand you also might want to look at this solution approach in the above mentioned post.
Related
I have a listbox with combined Employee Number and Name. so what you see is 0001-John Doe but now when I try and populate a text box with the list box info it does not work.
How I populate my listbox:
Private Sub UserForm_Initialize()
Dim conn As New ADODB.Connection
Dim rsst As New ADODB.Recordset
dbPath = Sheets("Info").Range("a2").Value
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
rsst.Open "SELECT EmpNumber,EmpFirstName,EmpSurname FROM Employees;", _
conn, adOpenStatic
With rsst
.MoveFirst
Do Until .EOF
Me.lbxNextOfKinEmployeeNumber.AddItem rsst.Fields(0).Value & " - " & rsst.Fields(1) & " " & " " & rsst.Fields(2) & " "
rsst.MoveNext
Loop
End With
End Sub
What's in my view button:
Private Sub btnNextOfKinSelect_Click()
Dim CNOK As New ADODB.Connection
Dim RNOK As New ADODB.Recordset
txtNextofKinEmployeeNumber.Enabled = False
'btnEditNextOfKin.Visible = True
If lbxNextOfKinEmployeeNumber.ListIndex = -1 Then
MsgBox "Please Select a Employee Number"
Else
dbPath = Sheets("Info").Range("a2").Value
CNOK.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
RNOK.Open "SELECT * FROM EmployeeNextOfKin Where EmpNumber ='" &
Me.lbxNextOfKinEmployeeNumber & "'", _
CNOK, adOpenStatic
RNOK.MoveFirst
txtNextofKinEmployeeNumber.Value = RNOK("EmpNumber")
txtNextOfKinName.Value = RNOK("NextOfKinName")
txtNextOfKinSurname.Value = RNOK("NextOfKinSurname")
txtContactNumber.Value = RNOK("NextofKinContactNumber")
txtContactAddressLine1.Value = RNOK("NextofKinAddress")
txtNextofKinCity.Value = RNOK("NextofKinCity")
txtCellNumber.Value = RNOK("NextofKinCellNumber")
End If
End Sub
What I want is when I select 0001-John Doe it should get the data from my database and populate my textboxes.
Code is trying to match concatenated string 0001-john doe with EmpNumber field value 0001. Options:
set listbox RowSource as multi-column
Do Until rsst.EOF
With Me.lbxNextOfKinEmployeeNumber
.ColumnCount = 2
.ColumnWidths = "0;2"
.AddItem rsst(0) & ";" & rsst(0) & " - " & rsst(1) & " " & rsst(2)
End With
rsst.MoveNext
Loop
If users would prefer to type name, don't include EmpNumber in concatenated string. Last name first might be more appropriate:
.AddItem rsst(0) & ";" & rsst(2) & ", " & rsst(1)
Might want to sort recordset: ORDER BY EmpSurname
extract EmpNumber from concatenated string
Left(Me.lbxNextOfKinEmployeeNumber, 4)
use LIKE and wildcard
WHERE '" & Me.lbxNextOfKinEmployeeNumber & "' LIKE [EmpNumber] & '*'"
My query works fine outside of the loop when I have the hard-coded values in. When I put the query inside my loop and use variables to hold the correct values it returns EOF. I've printed out the query and run it directly in SQL server and it returns the correct results. Which makes me think my SQL syntax is ok, but I can't figure out why it doesn't return anything in the loop. Any Ideas?
Public Function getPOs()
Dim TotalPos, Curpo, Query, ClaimNum, Color, DCloc As String
Dim i As Integer
Dim Row, Style, LastRow As LongPtr
Dim ws As Worksheet
Set ws = Worksheets("test")
' Set up database connection
Dim cnn As ADODB.Connection
Dim rs As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.ConnectionString = SQL_SERVER_CONNECTION
cnn.ConnectionTimeout = 0
cnn.CommandTimeout = 0
cnn.Open
'This query works fine, it returns results that I can iterate through.
rs.Open "SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = '1337' AND STYLE = '293493' and COLOR = '03' AND DC_LOCATION = 'PFC'", cnn, adOpenDynamic, adLockOptimistic
' Itereate through the results
i = 0
Do While Not rs.EOF
If rs![PO] = "" Then
Exit Do
End If
If i = 0 Then
Curpo = rs![PO]
TotalPos = Curpo
Else
Curpo = rs![PO]
TotalPos = TotalPos & ", " & Curpo
End If
i = i + 1
rs.MoveNext
Loop
MsgBox TotalPos ' Works fine!
' For some reason adding the query inside this loop messes it up.
Row = 11
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
rs.Close
While Row < 12 ' will change back to LastRow once working
'Parse the claim number
ClaimNum = Replace(ws.Cells(Row, 10), "IC - ", "")
MsgBox ClaimNum
'Style
Style = Left(ws.Cells(Row, 11), Len(ws.Cells(Row, 11)) - 2)
MsgBox Style
'Color
Color = ws.Cells(Row, 12)
MsgBox Color
'DCloc
DCloc = ws.Cells(Row, 13)
MsgBox DCloc
' When I add the query here it returns nothing...
rs.Open "SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = " & ClaimNum & " AND STYLE = " & Style & " and COLOR = '" & Color & "' AND DC_LOCATION = ' " & DCloc & "'", cnn, adOpenDynamic, adLockOptimistic
'add the entire sql statement to the Query var so I can print it out and run it in SQL Server
Query = "SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = " & ClaimNum & " AND STYLE = " & Style & " and COLOR = '" & Color & "' AND DC_LOCATION = '" & DCloc & "'"
' print the query... when I run this exact thing in SQL server it returns results just fine'
MsgBox Query
' iterate through results
i = 0
'rs.EOF now that it's in the loop... but why? I know the syntax of the query is correct, it returns results when I run it directly in SQL server
If rs.EOF Then
MsgBox "why???"
End If
Do While Not rs.EOF
If rs![PO] = "" Then
Exit Do
End If
If i = 0 Then
Curpo = rs![PO]
TotalPos = Curpo
Else
Curpo = rs![PO]
TotalPos = TotalPos & ", " & Curpo
End If
MsgBox TotalPos
i = i + 1
rs.MoveNext
Loop
rs.Close
Row = Row + 1
Wend
cnn.Close
End Function
rs.Open "SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = " & ClaimNum & " AND STYLE = " & Style & " and COLOR = '" & Color & "' AND DC_LOCATION = ' " & DCloc & "'"
Don't concatenate parameter values into your SQL string - that way you don't need to care about quoting strings and worry about whether a string contains apostrophes, or worse - the widely-known tale of Little Bobby Tables captures just how impactful this careless value concatenation practice can be, if you let it.
Instead, define your query once, and let the server deal with the parameters (it's its job).
Const sql As String = _
"SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = ? AND STYLE = ? AND COLOR = ? AND DC_LOCATION = ?"
Each ? is understood by ADODB as a positional parameter: all you need to do now, is to execute a ADODB.Command with 4 parameters, appended in the order they are specified.
Now you can write a Function that takes the values for the 4 parameters you need, and the function can return a ADODB.Recordset that contains the results - no need to redefine the SQL string every time you need it!
Private Function GetPO(ByVal cnn As ADODB.Connection, ByVal ClaimNum As String, ByVal Style As String, ByVal Color As String, ByVal DCloc As String) As ADODB.Recordset
Const sql As String = _
"SELECT PO " & _
"FROM [catalog].[dbo].[table] " & _
"WHERE CLAIM_NUMBER = ? AND STYLE = ? AND COLOR = ? AND DC_LOCATION = ?"
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cnn
cmd.CommandType = adCmdText
cmd.CommandText = sql
'TODO: verify parameter types & sizes - here NVARCHAR(200).
'NOTE: parameters must be added in the order they are specified in the SQL.
cmd.Parameters.Append cmd.CreateParameter(Type:=adVarWChar, Size:=200, Value:=ClaimNum)
cmd.Parameters.Append cmd.CreateParameter(Type:=adVarWChar, Size:=200, Value:=Style)
cmd.Parameters.Append cmd.CreateParameter(Type:=adVarWChar, Size:=200, Value:=Color)
cmd.Parameters.Append cmd.CreateParameter(Type:=adVarWChar, Size:=200, Value:=DCloc)
Set GetPO = cmd.Execute
End Function
You can use it from anywhere you have an ADODB.Connection that's ready to use:
Dim rs As ADODB.Recordset
Set rs = GetPO(cnn, ClaimNum, Style, Color, DCloc)
Do While Not rs.EOF
'...
Loop
You need to wrap variables in quotes to make it work, a string type isn't enough.
"WHERE CLAIM_NUMBER = " & ClaimNum & " ...
Needs to become:
"WHERE CLAIM_NUMBER = " & "'" & ClaimNum & "'" & " ...
In addition to all the other variables you are concatenating into the SQL statement
As an aside
Dim TotalPos, Curpo, Query, ClaimNum, Color, DCloc As String
is only declaring DCloc as a string and all the others are variants.
To make them all string you need to add as string to all of them.
Dim TotalPos as string, Curpo as string, Query as string, ClaimNum as string, Color as string, DCloc As String
My Code is following. I'll try to copy a range of data from a closed sheet with connectionstrings. The Code is okay if the dataname hasn't a empty string.
e.g. test.xlsx is okay but test further.xlsx get broken.
'using sql
Sub ImportThisFile(FilePath As String, SourceSheet As String, Destination As Range)
Set Conn = New ADODB.Connection
'xls
'Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
' FilePath & ";Extended Properties=Excel 8.0;"
'xlsx
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & _
FilePath & ";Extended Properties=Excel 12.0 Xml;"
Sql = "SELECT * FROM [" & SourceSheet & "$] WHERE [fieldname] <> " & [""""""]
Set RcdSet = New ADODB.Recordset
RcdSet.Open Sql, Conn, adOpenForwardOnly
Destination.CopyFromRecordset RcdSet
RcdSet.Close
Set RcdSet = Nothing
Conn.Close
Set Conn = Nothing
End Sub
Sub StartDoingStuff()
Dim Zeit As Long, Anzahl As Long
Anzahl = 1
Zeit = Timer
Dim testvar As String, testvar2 As String, testvar3 As String
testvar = "C:\Users\Admin\Desktop\Folder\"
testvar2 = "testdata with emptystrings.xlsx.xlsx"
testvar2 = "test.xlsx"
testvar3 = "Tabelle1"
ImportThisFile testvar & testvar2, "Timesheet", Range(testvar3 & "!A2")
Debug.Print "Zeitbedarf"; Round(Timer - Zeit, 3)
End Sub
And Second Question.
If I want to copy a range, how i must write the code?
I need to determine the last cell in a column. How is that possible ?
the code i posted is correct. It was a mistake in the workbook (tablename)
Im developing with vba in excel and wanna create some excelsheets to render a pivot table and a chart.
I did it with recordset which was returned from a custom mdx query. I have a example below which returns the data from the cube into a recordset then creates a pivottable and a chart. Working like a charm.
Public Sub CreatePivotTableAndChart()
Dim MDXQuery As String
'Declare variables
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
On Error GoTo ErrorHandler
'Open Connection
conn.ConnectionString = "Provider=MSOLAP.7;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=xxxxxxx;Data Source=xxxxxxxx;MDX Compatibility=1;Safety Options=2;Protocol Format=XML;MDX Missing Member Mode=Error;Packet Size=32767"
conn.Open
'Custom MDX query
MDXQuery = "WITH" & vbCrLf & _
"MEMBER [Measures].[DateValue] AS [DT_dTime].[Date].MemberValue" & vbCrLf & _
"SELECT {[Measures].[DT_mTransactions_Count], [Measures].[DateValue]} ON COLUMNS," & vbCrLf & _
"(Filter([DT_dTime].[Date].[Date].ALLMEMBERS, [Measures].[DT_mTransactions_Count] > 0)) ON ROWS" & vbCrLf & _
"FROM ( SELECT ( { [DT_dTags_Gender].[ParentTagID].&[4061],[DT_dTags_Gender].[ParentTagID].&[4062] } ) ON COLUMNS" & vbCrLf & _
"FROM [DT_BizTrackCube])" & vbCrLf & _
"WHERE ([DT_dTime].[Month].&[2018-01-01T00:00:00], [DT_dTags_MeasureType].[ParentTagID].&[8])"
rs.Open MDXQuery, conn
'Create new pivot cache
Set ws = ThisWorkbook.Worksheets("TestPivotTable")
Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal)
rs.MoveFirst
'Set recordset
Set pc.Recordset = rs
'Create new pivot table
Set pt = pc.CreatePivotTable(TableDestination:=ws.Range("A1"), TableName:="PivotTable")
'define pivotfields
pt.PivotFields("[Measures].[DateValue]").Orientation = xlRowField
pt.PivotFields("[Measures].[DT_mTransactions_Count]").Orientation = xlDataField
pt.ManualUpdate = False
'Create new pivot chart
Dim objShape As Shape
ActiveSheet.PivotTables("PivotTable").PivotSelect "", xlDataAndLabel, True
Set objShape = ActiveSheet.Shapes.AddChart2(227, xlLine)
With objShape
.Select
'Name formatting, position
.Name = "PivotChart"
.Left = Range("E1").Left
.Top = Range("E1").Top
.Width = 646
.Height = 300
'Titles
.chart.HasTitle = True
.chart.ChartTitle.Text = "Maand vergelijking"
.chart.Axes(xlCategory, xlPrimary).HasTitle = True
.chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Dagen"
.chart.Axes(xlValue, xlPrimary).HasTitle = True
.chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Leads"
End With
'Close recordset
rs.Close
'Reset recordset
Set rs = Nothing
'Close connection
conn.Close
'Reset connection
Set conn = Nothing
Done:
Exit Sub 'Exit to avoid error handler
ErrorHandler:
Debug.Print "ErrorHandler"
' Get VB Error Object's information
strTmp = "VB Error # " & Str(Err.Number)
strTmp = strTmp & vbCrLf & " Generated by " & Err.Source
strTmp = strTmp & vbCrLf & " Description " & Err.Description & vbCrLf
Debug.Print strTmp
End Sub
The only problem is with this solution I have flattenend result. I wanna use for example a mdx query with cross join so i can use row grouping (dimensions). The result is a multidimensional result.
I know that the cube returns a cellset but how can i create a pivot table from a cellset? Is that even possible. I found some examples how you can read a cellset and print the result to a flat table but
not one how to create a pivot table from it.
Hope you can help me out. Thanks in advance.
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