I've attached an Example Database with unfinished query that I am looking for help with, image shows what https://dl.dropboxusercontent.com/u/9829095/Result.jpg
Example Database: https://dl.dropboxusercontent.com/u/9829095/Song-V2.accdb
Working solution from Duane Hookom.
Example according to your structure:
SELECT distinct ID
,Concatenate("SELECT distinct Genre FROM qrySong4Export WHERE ID =" & [ID]) as Genre
,Concatenate("SELECT distinct Artist FROM qrySong4Export WHERE ID =" & [ID]) as Artist
from qrySong4Export
Output:
ID Genre Artist
1 Genre 2, Genre 8 6, 12
2 Genre 9 1, 17
3 Genre 10, Genre 13 5
4 Genre 12 4, 5
Code (add it Create -> Module -> [Paste]):
Function Concatenate(pstrSQL As String, _
Optional pstrDelim As String = ", ") _
As String
'Created by Duane Hookom, 2003
'this code may be included in any application/mdb providing
' this statement is left intact
'example
'tblFamily with FamID as numeric primary key
'tblFamMem with FamID, FirstName, DOB,...
'return a comma separated list of FirstNames
'for a FamID
' John, Mary, Susan
'in a Query
'SELECT FamID,
'Concatenate("SELECT FirstName FROM tblFamMem
' WHERE FamID =" & [FamID]) as FirstNames
'FROM tblFamily
'
'======For DAO uncomment next 4 lines=======
'====== comment out ADO below =======
'Dim db As DAO.Database
'Dim rs As DAO.Recordset
'Set db = CurrentDb
'Set rs = db.OpenRecordset(pstrSQL)
'======For ADO uncomment next two lines=====
'====== comment out DAO above ======
Dim rs As New ADODB.Recordset
rs.Open pstrSQL, CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
Dim strConcat As String 'build return string
With rs
If Not .EOF Then
.MoveFirst
Do While Not .EOF
strConcat = strConcat & _
.Fields(0) & pstrDelim
.MoveNext
Loop
End If
.Close
End With
Set rs = Nothing
'====== uncomment next line for DAO ========
'Set db = Nothing
If Len(strConcat) > 0 Then
strConcat = Left(strConcat, _
Len(strConcat) - Len(pstrDelim))
End If
Concatenate = strConcat
End Function
Related
I'm trying to loop through email messages in Outlook, scrap unique ID numbers and concatenate them as one string.
Each message contains several different IDs that are multiplied across the email, like these:
ID 1111, ID 2222
ID 1111, ID 33333, ID 2222
ID 1111, ID 2222, ID 444, ID 33333
ID 2222, ID 1111
Then expected result would be (sorted):
ID 444, ID 1111, ID 2222, ID 33333
Here is my code.
Sub Scrap_IDs()
Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
Dim olFolder As MAPIFolder: Set olFolder = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("Folder_name")
Dim olMail As Variant: For Each olMail In olFolder.Items
Dim mBody As String: mBody = olMail.Body
With olMail
' Scrap all IDs using regex
With New RegExp
.Global = True
.Pattern = "ID[ \d]+"
Dim MatchID As Object: For Each MatchID In .Execute(mBody)
Dim i As Long: Dim arrMatchID(): ReDim Preserve arrMatchID(i)
arrMatchID(i) = MatchID.Value
i = i + 1
Next
End With
' Remove duplicates from array
Dim RemArrDups As Variant: RemArrDups = WorksheetFunction.Sort(WorksheetFunction.Unique(WorksheetFunction.Transpose(arrMatchID)))
' Concatenate array items
Dim IDs As String: IDs = Join(RemArrDups, ", ")
End With
Next
End Sub
The line related to concatenation gives run-time error 5 "Invalid procedure call or argument". Why is that?
It works if I use the Join function on arrMatchID instead of RemArrDups, but this way the values won't be unique.
Using Microsoft 365's UNIQUE and SORT in VBA
' This is a 1D array, a single row.
Dim arrMatchId(): arrMatchId = Array( _
"ID 667", "ID 3", "ID 1111", "ID 2222", "ID 3", "ID 44", "ID 667")
' Remove duplicates and sort the array.
' Keep it a single row (don't transpose). Use 'True' as the parameters
' for the 'col' arguments of both functions.
Dim RemArrDups(): RemArrDups _
= Application.Sort(Application.Unique(arrMatchId, True), , , True)
' Join.
Dim IDs As String: IDs = Join(RemArrDups, ", ")
Debug.Print IDs
I need select data from database, using Excel. I want to select only one column from database and I need use where statement (to select only data which have the same unique value as data in Excel sheet)
I tried this
Sub DB_RTVresult()
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim myRes As ADODB.Recordset
Server_Name = "123" ' Enter your server name here
Database_Name = "DBName" ' Enter your database name here
User_ID = "UserName" ' enter your user ID here
Password = "Pass" ' Enter your password here
Set myCon = New ADODB.Connection
Worksheets(2).Select
LastRow = GetRowCnt
For bl = LastRow To 5 Step -1
myCon.ConnectionString = "Driver={SQL Server};Server=" & Server_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";Database=" & Database_Name & ";"
myCon.Open
SQLStr = "SELECT [RTV_RESULT]" & _
"FROM [WSCZWMS].[WSCZWMS].[OMEGA_E2E_REPORT] WHERE [SME_TRACK_NO] ='" & Cells(bl, "CC").Value & "'"
Set myRes = myCon.Execute(SQLStr)
Worksheets("HelpTables").Range("E2" & Rows.Count).End(xlUp).Offset (1)
StrQuery = "OMEGA_SPEQ_REPORT"
myCon.Close
Set myRes = Nothing
Set myCon = Nothing
Next
End Sub
But when I run it, it writes Application-define or object-define error.
and colored this line
Worksheets("HelpTables").Range("E2" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset myRes
This line dave the select data into first empty row in column E, (start on 3rd row)
Do you have any idea how to solve this?
The reason for your issue is, that you are already referring to the Row in your .Range("E2" & Rows.Count) .
If you modify the mentioned line to the following, it should work properly:
Worksheets("HelpTables").Cells(Rows.Count, 5).End(xlUp).Offset(1).CopyFromRecordset myRes
The 5 in .Cells(Rows.Count, 5) is for the fifth column ('E').
I am not sure, but it seems that your excel objects Cells dans Rows should be affected and your sheets selected.
I would have writen
For b1=...
Worksheets(2).select
...
... Worksheets(2).cells(b1,"CC").value
...
Worksheets("HelpTables").select
Worksheets("HelpTables").Range("E" & _
Worksheets("HelpTables").Range("E:E").Rows.Count).End(xlUp).Offset(1) ...
...
NB :
"CC" is the name of a Excel value ?
Do you want Range("E2" & rows.count) to go to E2100 if there are 100 rows ? That's why I wrote "E" and not "E2" in my proposition. But may be you wanted (... rows.count+2) ?
Hope it helps.
Pierre.
I have a couple macros to make calls to SSMS 2014 to run a query and return the results in a defined cell in my worksheet. They work successfully, but when I try to use certain queries with temp tables I get the following error message:
I have researched online and the best answer I can find is to add SET NOCOUNT ON at the beginning of my query. I tried that, and still got the same message.
The piece of code that the Debug brings me to is as follows:
bqr.Range("B6").CopyFromRecordset rst
The meat and potatoes of my code, along with the variable setups that matter, is as follows:
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim SOURCE As String
Dim DATABASE As String
Dim QUERY As String
Dim intColIndex As Integer
Dim sDate As String
Dim eDate As String
Dim qt As Worksheet
Dim qtr As Worksheet
Dim bqr As Worksheet
Dim bp As Worksheet
ConnectionString = "Provider=SQLOLEDB;Data Source=" & SOURCE & "; Initial Catalog=" & DATABASE & "; Integrated Security=SSPI;"
cnn.Open ConnectionString
cnn.CommandTimeout = 900
StrQuery = QUERY
rst.Open StrQuery, cnn
bqr.Range("B6").CopyFromRecordset rst
For intColIndex = 0 To rst.Fields.Count - 1
Range("B5").Offset(0, intColIndex).Value = rst.Fields(intColIndex).Name
Next
The most confusing part is that the error suggests that my rst recordset is closed, even though it is opened just before I use the CopyFromRecordset
I've tried adding DROP TABLE at the end of my query, the SET NOCOUNT ON function at the beginning, and even tested some smaller simple temp tables as tests.
For example, I set my QUERY variable to:
QUERY = "CREATE TABLE #Test1 (TestID INT, TestValue VARCHAR(20))"
QUERY = QUERY + " INSERT INTO #Test1"
QUERY = QUERY + " VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')"
QUERY = QUERY + " SELECT * INTO #Test2 FROM #Test1 WHERE TestID = 1"
QUERY = QUERY + " SELECT * FROM #Test2"
Then ran the code to extract and past into Excel, and it worked.
Therefore, I am stumped. Maybe there is a limit to how long the query can be? Right now it's 180 lines long, so it's pretty big...
Any suggestions are appreciated!
EDIT: Full macro below (less the actual query):
Private Sub CommandButton1_Click()
If TextBox1.Value = "i.e. 20160101" Or TextBox2.Value = "i.e. 20160131" Then
MsgBox "Please fill out all fields before proceeding"
ElseIf Len(TextBox1.Value) <> 8 Or Len(TextBox2.Value) <> 8 Or Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then
MsgBox "Please use correctly formatted Datekeys (i.e. yyyymmdd)"
Else
Application.DisplayAlerts = False
Sheets(ActiveWorkbook.Sheets.Count).Select
While ActiveSheet.Name <> "[worksheet I want to keep]"
ActiveSheet.Delete
Sheets(ActiveWorkbook.Sheets.Count).Select
Wend
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim SOURCE As String
Dim DATABASE As String
Dim QUERY As String
Dim intColIndex As Integer
Dim sDate As String
Dim eDate As String
Dim qtr As Worksheet
Dim bqr As Worksheet
Dim bp As Worksheet
Set qtr = Sheets([sheet name])
Sheets.Add after:=qtr
Set bqr = ActiveSheet
bqr.Name = "[sheet name]"
Sheets.Add after:=bqr
Set bp = ActiveSheet
bp.Name = "[sheet name]"
SOURCE = "[server]"
DATABASE = "[database]"
sDate = UserForm1.TextBox1.Value
eDate = UserForm1.TextBox2.Value
QUERY = "[beginning of query]"
QUERY = QUERY + " [more query here]" 'This gets repeated a lot for each additional line in the query'
qtr.Select
Range("B6").Select
While ActiveCell.Value <> ""
QUERY = QUERY + " " + ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Wend
QUERY = QUERY + " [more query here]" 'This gets repeated a lot for the remaining lines in the query'
ConnectionString = "Provider=SQLOLEDB;Data Source=" & SOURCE & "; Initial Catalog=" & DATABASE & "; Integrated Security=SSPI;"
cnn.Open ConnectionString
cnn.CommandTimeout = 2000
StrQuery = QUERY
rst.Open StrQuery, cnn
bqr.Range("B6").CopyFromRecordset rst
For intColIndex = 0 To rst.Fields.Count - 1
Range("B5").Offset(0, intColIndex).Value = rst.Fields(intColIndex).Name
Next
End If
Application.DisplayAlerts = True
End Sub
Start your T-SQL query with set nocount on;
QUERY = "set nocount on;"
QUERY = QUERY & "declare #Test1 table (TestID INT, TestValue VARCHAR(20))"
QUERY = QUERY & " INSERT INTO #Test1"
QUERY = QUERY & " VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')"
QUERY = QUERY & " SELECT * FROM #Test1 WHERE TestID = 1"
Then it should work. The next example will also work and is a bit closer to your example (yet using table variables).
set nocount on;
declare #Test1 table (TestID INT, TestValue VARCHAR(20))
declare #Test2 table (TestID INT, TestValue VARCHAR(20))
INSERT INTO #Test1
VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')
insert into #Test2
select *
from #Test1 WHERE TestID = 1
select * from #Test2
I am trying to write a macro to query from our database using the IN clause except with one problem. I am reaching the limit of the IN clause for SQL Server.
My macro looks like this:
Dim row_count As Double
row_count = ActiveSheet.UsedRange.Rows.Count - 1
half_row_count = row_count
Dim i As Double
Dim products As String
For i = 2 To half_row_count
Dim product_id As String
product_id = Cells(i, 1).Value
'test = sixtyDays(product_id, conn)
'Cells(i, 10).Value = test
products = products & "'" & product_id & "'" & ", "
Next i
Dim sample As New ADODB.Recordset
products = Left(products, Len(products) - 2)
Set sample = sixtyDays(products, conn)
Sheets(1).Range("K2").CopyFromRecordset sample
conn.Close
Function sixtyDays(ProductID As String, new_conn As ADODB.Connection) As ADODB.Recordset
Dim sConnString As String
Dim rst As New ADODB.Recordset
Dim recordsAffecfted As Long
StrQuery = "SELECT ProductAnalysisByMonth.SalesQty FROM ProductAnalysisByMonth WHERE ProductAnalysisByMonth.ProductID IN (" + ProductID + ") AND ProductAnalysisByMonth.Month = " + CStr(Month(Date) - 2)
rst.Open StrQuery, new_conn
Set sixtyDays = rst
End Function
So I need to some how split the query into smaller chunks, except, the number of arguments passed to the SQL query will vary from week to week.
What is the most efficient way of handling this problem?
Create a table function that will return your string results into a data-set that can be inserted into a CTE, temp table, or used directly in a join. This has been the most effective way for me to get around this limitation. Below is a link to Ole Michelsen's website who provides a simple but flexible solution.
Link: http://ole.michelsen.dk/blog/split-string-to-table-using-transact-sql.html
I have the following spreadsheet structure.
ID, Storage_name, Name_of_product, Quantity_used, Date_Used
The user gives the start and end date and I have to populate all the quantities used of all the products present in the storage between those start/end dates.
For Example
if the structure is
ID Storage_name Name_of_Product Quantity used Date_used
1 st1 pro1 2 11/1/2011
2 st2 pro2 5 11/2/2011
1 st1 pro1 3 11/2/2011
4 st1 pro3 5 11/4/2011
and the user selects st1 as the storage location and 11/01/2011 and 11/04/2011 as start and end date my output should be
ID Storage_name Name_of_Product Quantity used
1 st1 pro1 7
4 st1 pro3 5
I am not using databases (I wish I was). Which is the best way to do this.
I am running three loops first from start to end, second to check the storage_name, third to check the Name_of_product and then updating the quantity_counter but its becoming messy. there should be a better way to do this. I am writing the output to a file.
Thanks
P.S I know I do not have to use the column storage_name in the output file. Either ways is fine.
I am doing this
Dim quantity as long
storageName= selectWarehouse.Value ' from combo box
quantity = 0
With Worksheets("Reports")
lastrow = .Range("A1").SpecialCells(xlCellTypeLastCell).row + 1
End With
row = 2
While (row < lastrow)
If CStr((Worksheets("Reports").Cells(row, 2))) = storageName Then
name = CStr((Worksheets("Reports").Cells(row, 3)))
quantity = quantity + CLng(Worksheets("Reports").Cells(row, 4))
End If
row = row + 1
Wend
I am checking for date in the beginning. That part is fine.
You could use a dictionary. Here is some pseudo code that can get you started.
Start
If range = storageName then
if within the date range then
If not dictionary.exists(storageName) then dictionary.add storageName
dictionary(storageName) = dictionary(storageName) + quantity
Loop
Now you only have to loop through the cells once.
You can use SQL with ADO and Excel
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
''This is not the best way to refer to the workbook
''you want, but it is very convenient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''
''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 _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Some rough notes on input
sName = [A1]
dteStart = [A2]
dteEnd = [A3]
''Jet / ACE SQL
strSQL = "SELECT ID, Storage_name, Name_of_Product, Sum([Quantity used]) " _
& "FROM [Report$] a " _
& "WHERE Storage_name ='" & sName _
& "' AND Date_Used Between #" & Format(dteStart, "yyyy/mm/dd") _
& "# And #" & Format(dteEnd, "yyyy/mm/dd") _
& "# GROUP BY ID, Storage_name, Name_of_Product"
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet for the results
Worksheets("Sheet3")
For i = 0 To rs.Field.Count
.Cells(1, i+1) = rs.Fields(i).Name
Next
.Cells(2, 1).CopyFromRecordset rs
End With
''Tidy up
rs.Close
Set rs=Nothing
cn.Close
Set cn=Nothing
I didn't test the code below but something like this should work for you. Also, I have a reference to the dictionary object but you can late bound it too.
Public Sub FilterTest(ByVal sStorageName As String, ByVal dDate1 As Double, ByVal dDate2 As Double)
Dim dicItems As Dictionary
Dim i As Long, lRowEnd As Long, lItem As Long
Dim rData As Range, rResults As Range
Dim saResults() As String
Dim vData As Variant
Dim wks As Worksheet, wksTarget As Worksheet
'Get worksheet object, last row in column A, data
Set wksTarget = Worksheets("Target")
Set wks = Worksheets("Reports")
lRowEnd = wks.Range(Rows.Count).End(xlUp).Row
Set rData = wks.Range(wks.Cells(1, 1), wks.Cells(lRowEnd, ColumnNames.ColumnEnd))
'Place data in 2D array
vData = rData
'Loop through data and gather correct data in dictionary
Set dicItems = New Dictionary
ReDim saResults(1 To 10, 1 To 4)
For i = 1 To lRowEnd
If vData(i, ColumnNames.Storage_name + 1) = sStorageName Then
If vData(i, ColumnNames.Date_used + 1) >= dDate1 And vData(i, ColumnNames.Date_used + 1) <= dDate2 Then
If dicItems.Exists(vData(i, ColumnNames.Name_of_Product + 1)) Then
'Determin location in array
lItem = dicItems(vData(i, ColumnNames.Name_of_Product + 1))
'Add new value to array
saResults(dicItems.Count + 1, 4) = CStr(CDbl(saResults(dicItems.Count + 1, 4)) + CDbl(vData(i, ColumnNames.Quantity_used + 1)))
Else
'If new add new item to results string array
saResults(dicItems.Count + 1, 1) = CStr(vData(i, ColumnNames.ID + 1))
saResults(dicItems.Count + 1, 2) = CStr(vData(i, ColumnNames.Storage_name + 1))
saResults(dicItems.Count + 1, 3) = CStr(vData(i, ColumnNames.Name_of_Product + 1))
saResults(dicItems.Count + 1, 4) = CStr(vData(i, ColumnNames.Quantity_used + 1))
'Add location in array
dicItems.Add vData(i, ColumnNames.Name_of_Product + 1), dicItems.Count + 1
End If
End If
End If
Next i
ReDim Preserve saResults(1 To dicItems.Count, 1 To 4)
'Print Results to target worksheet
With wksTarget
Set rResults = .Range(.Cells(1, 1), .Cells(dicItems.Count, 4))
rResults = saResults
End With
End Sub