I'm really sorry to be asking and I'm sure it's extremely simple to answer but whenever I try to run the macro in excel below, I get the error message stated in the title:
Sub CallsMacro()
Dim ConData As ADODB.Connection
Dim rstData As ADODB.Recordset
Dim wsSheet As Worksheet
Dim strServer As String
Dim strDatabase As String
Dim strFrom As String
Dim strto As String
Dim intCount As Integer
Set wsSheet = ActiveWorkbook.Worksheets("Refresh")
With wsSheet
strServer = "TNS-CCR-02"
strDatabase = "AvayaSBCCRT"
strFrom = .Range("C$2")
strto = .Range("C$3")
End With
Set ConData = New ADODB.Connection
With ConData
.ConnectionString = "Provider=SQLOLEDB;Data Source=" & strServer & ";" & "Initial Catalog=" & ";" & "persist security info=true;" & "User Id=dashboard; Password=D4$hboard;"
.CommandTimeout = 1800
.Open
End With
''Create the recordset from the SQL query
Set rstData = New ADODB.Recordset
Set wsSheet = ActiveWorkbook.Worksheets("Calls")
With rstData
.ActiveConnection = ConData
.Source = "SELECT DISTINCT CAST(c.createdate AS date) as [Date]," & _
"CASE WHEN c.[CategoryID] = 1 then 'Outbound' WHEN c.[CategoryID] = 2 then 'Inbound' Else 'Internal' end as [Direction], c.cli as [Number], c.ddi, 'CallCentre' as [Queue], '' as [Queue Time], u.username as [Agent], cast((c.DestroyDate - c.CreateDate) as TIME) as [Duration], 'Connected' as [Status], c.callID as [Reference]" & _
"FROM [AvayaSBCCRT].[dbo].[tblAgentActivity] as a" & _
"JOIN [AvayaSBCCRT].[dbo].[tblCallList] as c on c.calllistid = a.calllistid" & _
"JOIN [AvayaSBCCRT].[dbo].[tblUsers] as u on u.userid = a.AgentID" & _
"WHERE c.createdate between '" & strFrom & "' and '" & strto & "'" & _
"AND a.[ActivityID] = 3 "
.CursorType = adOpenForwardOnly
.Open
End With
wsSheet.Activate
Dim Lastrow As Long
Lastrow = Range("A" & Rows.Count).end(xlUp).Row
Range("A2:J" & Lastrow).ClearContents
If rs.EOF = False Then wsSheet.Cells(2, 1).CopyFromRecordset rsData
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
End Sub
I've looked high and low and cannot find the reason for it. Anybody have any ideas?
You're missing spaces from the end of the lines. Your SQL contains for example:
[tblAgentActivity] as aJOIN [AvayaSBCCRT].[dbo].[tblCallList]
Related
I would like to know how to get a stored procedure as a text and update its twin(!) on the other server with an excel macro. So I got this stored procedure on the server which has the newest version of the stored procedure:
Declare #Lines Table (Line NVARCHAR(MAX));
Declare #FullText NVARCHAR(max) = '';
INSERT #Lines EXEC sp_helptext 'StoredProcName';
Select #FullText = #FullText + Line From #Lines;
Select #FullText
#Fulltext has the complete code of 'StoredProcName'. I would like to get this code, cut the first 6 letters (CREATE), append it with "ALTER" and run it on the target server/database to update its twin(!). I got this excel macro to realize it:
Sub GetStoredProcedure()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim cmd1 As ADODB.Command
Set cmd1 = New ADODB.Command
'Getting data from local
Set cn = New ADODB.Connection
cn.ConnectionString = _
"Provider=SQLOLEDB;" & _
"Data Source=myDataSource;" & _
"Initial Catalog=myDataBase;" & _
"Integrated Security=SSPI;"
cn.Open 'Connection establishment.
cmd1.ActiveConnection = cn
cmd1.CommandType = adCmdStoredProc
cmd1.CommandText = "UpdateStoredProcedure"
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Parameter = Cells(i, 1).Value
cmd1.Parameters.Refresh
cmd1.Parameters("#sPName").Value = Parameter
Set rs = cmd1.Execute
rs.Open
Debug.Print rs.State
Range("K2").CopyFromRecordset rs
Next i
rs.Close 'Deactivating the recordset.
cn.Close 'Deactivating the connetion.
End Sub
After running this macro I get the Run-time error '3704': Operation is not allowed when the object is closed.
Thanks in advance for your help.
Try
Option Explicit
Sub GetStoredProcedure()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim cmd1 As ADODB.Command
'Getting data from local
Set cn = New ADODB.Connection
cn.ConnectionString = _
"Provider=SQLOLEDB;" & _
"Data Source=myDataSource;" & _
"Initial Catalog=myDataBase;" & _
"Integrated Security=SSPI;"
cn.Open 'Connection establishment.
Dim sProc As String, sCode As String, n As Long, i As Long
With Range("K:L")
.Font.Name = "Lucida Console"
.Font.Size = 11
.NumberFormat = "#"
.ColumnWidth = 85
End With
Set cmd1 = New ADODB.Command
With cmd1
.ActiveConnection = cn
.CommandType = adCmdText
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
sProc = Cells(i, 1).Value
.CommandText = "EXEC sp_helptext '" & sProc & "';"
Set rs = .Execute
sCode = rs.GetString
sCode = Replace(sCode, vbCrLf & vbCrLf, vbCrLf)
Range("K" & i).Value = sCode
Range("L" & i).Value = Replace(sCode, "CREATE PROCEDURE", "ALTER PROCEDURE")
n = n + 1
Next i
End With
rs.Close 'Deactivating the recordset.
cn.Close 'Deactivating the connetion.
MsgBox n & " procedures", vbInformation
End Sub
I have a data table that has just a few columns: GLID, Metric Category, Amount, and Metric Date. The way the data is organized on the excel file I need to use is like a matrix as so:
The date columns are the metric date and the numbers below them are the amounts. As you can see for each date there is some amount that pertains to a particular metric category and in some cases a GLID. Now what I need to do in VBA is push the data into the format as so
GLID Metric Category Amount Metric Date
5500 Property Tax-5500 -8 3/31/2020
5500 Property Tax-5500 -8 4/30/2020
So on and so forth. I am completely new to VBA so this particular task is daunting and challenging for me and thus why I made a post here. If anyone has some suggestions I would greatly appreciate it.
So far this is the setup I have in VBA:
Sub second_export()
Dim sSQL As String, sCnn As String, sServer As String
Dim db As Object, rs As Object
sServer = "CATHCART"
sCnn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Portfolio_Analytics;Data Source=" & sServer & ";" & _
"Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;"
Set db = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
If db.State = 0 Then db.Open sCnn
End Sub
Note For Further Clarification:
The number of columns is 36 and the number of rows is 46 in the excel file. For the categories that do not have a GLID then we can push NULL if needed.
I can push data into the database when its simply and insert but I have to pivot the data such that the GLID and Metric category are repeated for their associated dates and amounts.
First create a sheet of data to upload
Option Explicit
Sub CreateDataSheet()
Dim wb As Workbook, ws As Worksheet, wsData As Worksheet, header As Variant
Dim iLastRow, iLastCol, dt As Variant, iOutRow
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' the matrix sheet
Set wsData = wb.Sheets("Sheet2") ' sheet to hold table data
wsData.Cells.Clear
wsData.Range("A1:D1") = Array("GLID", "Metric Category", "Amount", "Metric Date")
' get header
iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
header = ws.Range(ws.Cells(1, 3), ws.Cells(1, iLastCol))
'Debug.Print iLastRow, iLastCol, UBound(header, 2)
Dim r, c
iOutRow = 2
For r = 2 To iLastRow
For c = 1 To UBound(header, 2)
'Debug.Print r, header(1, c), ws.Cells(r, c + 2)
With wsData.Cells(iOutRow, 1)
.Offset(0, 0) = ws.Cells(r, 1)
.Offset(0, 1) = ws.Cells(r, 2)
.Offset(0, 2) = ws.Cells(r, c + 2)
.Offset(0, 3) = header(1, c)
End With
iOutRow = iOutRow + 1
Next
Next
wsData.Range("A1").Select
MsgBox iOutRow - 2 & " Rows created on " & wsData.Name, vbInformation
End Sub
Then create a table in the database
Sub CreateTable()
Const TABLE_NAME = "dbo.GL_TEST"
Dim SQL As String, con As Object
SQL = "CREATE TABLE " & TABLE_NAME & "( " & vbCr & _
"RECNO int NOT NULL," & vbCr & _
"GLID nchar(10)," & vbCr & _
"METRICNAME nvarchar(255)," & vbCr & _
"AMOUNT money," & vbCr & _
"METRICDATE date," & vbCr & _
"PRIMARY KEY (RECNO))"
'Debug.Print sql
Set con = mydbConnect()
'con.Execute ("DROP TABLE " & TABLE_NAME) ' use during testing
con.Execute SQL
con.Close
Set con = Nothing
MsgBox "Table " & TABLE_NAME & " created"
End Sub
using data connection.
Function mydbConnect() As Object
Dim sConStr As String
Const sServer = "CATHCART"
sConStr = "Provider=SQLOLEDB.1;" & _
"Integrated Security=SSPI;" & _
"Persist Security Info=True;" & _
"Initial Catalog=Portfolio_Analytics;" & _
"Data Source=" & sServer & ";" & _
"Use Procedure for Prepare=1;" & _
"Auto Translate=True;Packet Size=4096;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Then load the data from the sheet one record at a time with auto-commit off.
Sub LoadData()
Const TABLE_NAME = "dbo.GL_TEST"
Dim SQL As String
SQL = " INSERT INTO " & TABLE_NAME & _
" (RECNO,GLID,METRICNAME,AMOUNT,METRICDATE) VALUES (?,?,?,?,?) "
Dim con As Object, cmd As Object, rs As Variant
Set con = mydbConnect()
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandType = adCmdText
.CommandText = SQL
.Parameters.Append .CreateParameter("P1", adInteger, adParamInput)
.Parameters.Append .CreateParameter("P2", adVarWChar, adParamInput, 10)
.Parameters.Append .CreateParameter("P3", adVarWChar, adParamInput, 255)
.Parameters.Append .CreateParameter("P4", adCurrency, adParamInput)
.Parameters.Append .CreateParameter("P5", adDate, adParamInput)
End With
con.Execute "SET IMPLICIT_TRANSACTIONS ON"
Dim ws As Worksheet, iLastRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet2") ' sheet were table data is
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To iLastRow
cmd.Parameters(0).Value = i
cmd.Parameters(1).Value = ws.Cells(i, 1)
cmd.Parameters(2).Value = ws.Cells(i, 2)
cmd.Parameters(3).Value = ws.Cells(i, 3)
cmd.Parameters(4).Value = ws.Cells(i, 4)
cmd.Execute
Next
con.Execute "COMMIT"
con.Execute "SET IMPLICIT_TRANSACTIONS OFF"
rs = con.Execute("SELECT COUNT(*) FROM " & TABLE_NAME)
MsgBox rs(0) & " Rows are in " & TABLE_NAME, vbInformation
con.Close
Set con = Nothing
End Sub
Here's how you can loop over your data:
Sub Tester()
Dim rw As Range, n As Long
Dim GLID, category, dt, amount
For Each rw In ActiveSheet.Range("H2:AS47").Rows
'fixed per-row
GLID = Trim(rw.Cells(1).Value)
category = Trim(rw.Cells(2).Value)
'loopover the date columns
For n = 3 To rw.Cells.Count
dt = rw.Cells(n).EntireColumn.Cells(1).Value 'date from Row 1
amount = rw.Cells(n).Value
Debug.Print rw.Cells(n).Address, GLID, category, amount, dt
'insert a record using your 4 values
'switch GLID to null if empty
Next n
Next rw
End Sub
I have a excel workbook that pulls data into a table users can then fill in the missing dates in column 11. Column 1 is the unique identifier that matches the ID column in the SQL table. I want to create a macro that runs when the workbook is closed and will update the SQL table with the filled in dates, but I am struggling with the code. I have have tried two different things but neither seem to work.
Option 1:
Private Sub tableupdate()
Dim con As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rst As New ADODB.Recordset
Dim i As Long
Dim vDB As Variant
Dim ws As Worksheet
con.connectionstring = "Provider=SQLOLEDB;Password=*********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
con.Open
Set cmd.ActiveConnection = con
Set ws = ActiveSheet
vDB = ws.Range("A4").CurrentRegion
For i = 2 To UBound(vDB, 1)
cmd.CommandText = "UPDATE [dbo].[all_load_control] set Driver_arr_dte = ' " & vDB(i, 2) & " ' WHERE mst_ship_num = ' " & vDB(i, 1) & " ' "
cmd.Execute
Next i
con.Close
Set con = Nothing
End Sub
option 2:
Private Sub uplodblanks()
Dim r, c, con, dstring
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lRow
Dim ssql As String
con = "Provider=SQLOLEDB;Password=********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
r = 1
c = 1
Worksheets("WTUpload").Calculate
lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
cn.Open con
i = 1
For i = 1 To lRow
ssql = "update dbo.cxu_all_load_control set driver_arr_dte = " & CDate(Sheets("WTUpload").Cells(i, 11)) & " where mst_ship_num = " & CDbl(Sheets("WTUpload").Cells(i, 11)) & " ; "
cn.Execute ssql
Next i
cn.Close
End Sub
Any help as to why neither of these are working would be great
Replace the mydbConnect() function with you own method of getting a connection.
Sub tableupdate2()
Const COL_NUM As String = "A"
Const COL_DATE As String = "K"
Const TABLE As String = "dbo.all_load_control"
' define update sql
Const SQL As String = " UPDATE " & TABLE & _
" SET Driver_arr_dte = CAST(? AS DATETIME2) " & _
" WHERE mst_ship_num = ? "
' establish connection and create command object
Dim con As Object, cmd As Object, sSQL As String
Set con = mydbConnect() ' establish connection
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandText = SQL
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("P1", adVarChar, 1, 20) '
.Parameters.Append .CreateParameter("P2", adVarChar, 1, 50) ' adParamInput = 1
End With
' prepare to get data from spreadsheet
Dim wb As Workbook, ws As Worksheet, iLast As Integer, iRow As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("WTUpload")
iLast = ws.Range(COL_NUM & Rows.count).End(xlUp).Row
Dim p1 As String, p2 As String, count As Long
' scan sheet and update db
Debug.Print "Updates " & Now
With cmd
For iRow = 1 To iLast
p1 = Format(ws.Range(COL_DATE & iRow).Value, "yyyy-mm-dd hh:mm")
p2 = ws.Range(COL_NUM & iRow).Value
If len(p2) > 0 Then
.Parameters(0).Value = p1
.Parameters(1).Value = p2
Debug.Print "Row ", iRow, "p1=" & p1, "P2=" & p2
.Execute
count = count + 1
End If
Next
End With
' end
MsgBox "Rows processed = " & count, vbInformation, "Updates Complete"
con.Close
Set con = Nothing
End Sub
Edit - added connection and test code
Function mydbConnect() As Object
Dim sConStr As String
sConStr = "Provider=SQLOLEDB;Password=*********;User ID=clx_write;" & _
"Initial Catalog=DPEDataMartDBPrd01;" & _
"Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Sub test()
Dim con As Object, rs As Object
Set con = mydbConnect()
Set rs = con.Execute("SELECT CURRENT_TIMESTAMP")
MsgBox rs.Fields(0), vbInformation, "Current Date/Time"
End Sub
I have used below code but failed at step
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Can anyone help to check why?
Sub get_Data_From_DB()
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' Open a connection by referencing the ODBC driver.
cnn.ConnectionString = "driver={SQL Server};" & _
"server=aaaaa,2431;uid=bbb;pwd=ccc;database=ddd"
cnn.Open
' Find out if the attempt to connect worked.
If cnn.State = adStateOpen Then
MsgBox "Welcome to Pubs!"
Sql = "SELECT top 10 * from tableA(NOLOCK)"
Set rs = cnn.Execute(Sql)
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Else
MsgBox "Sorry. No Pubs today."
End If
' Close the connection.
cnn.Close
End Sub
Change this:
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
To something like this:
ActiveWorkbook.Sheets("Sheet1").Range("A1").CopyFromRecordset rs
You can change "A1" to another cell if you'd like.
EDIT: Here's how I'd actually organize this to make it flexible/reusable.
Sub runPubsQuery
Dim sqlStr As String
sqlStr = "SELECT top 10 * FROM tableA(NOLOCK)"
Call writeSqlResults(sqlStr,getConnectionString(),ThisWorkbook.Sheets("Sheet1"))
End Sub
Sub writeSQLResults(sqlStr As String, connStr As String, destWS As Worksheet, _
Optional errMsg As String = "Sorry. No Pubs today.", Optional welcMsg As String = "Welcome to Pubs!")
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim headerArr As Variant
cn.Open (connStr)
If Not cn.State = adStateOpen Then
MsgBox errMsg
Else
MsgBox welcMsg
Set rs = cn.Execute(sqlStr)
If Not rs.EOF Then
headerArr = getRecordHeaders(rs)
With destWS
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, UBound(headerArr, 2))).Value = headerArr
.Range("A2").CopyFromRecordset rs
End With
rs.Close
End If
End If
cn.Close
End Sub
Function getConnectionString(Optional serverName As String = "aaaa,2431", Optional dbName As String = "ddd", _
Optional uidStr As String = "bbb", Optional pwdStr As String = "ccc") As String
getConnectionString = "Driver={SQL Server};" & _
"Server=" & serverName & ";" & _
"Uid=" & uidStr & ";" & _
"Pwd=" & pwdStr & ";" & _
"Database=" & dbName & ";"
End Function
Function getRecordHeaders(rs As Variant) As Variant
If Not TypeName(rs) = "Recordset" Then
MsgBox "Error: Parameter rs is not a valid recordset"
Stop
Exit Function
End If
Dim i As Long
Dim j As Long
If Not rs.EOF Then
ReDim headerArr(1 To 1, 1 To rs.Fields.Count) As Variant
j = 0
For i = LBound(headerArr, 2) To UBound(headerArr, 2)
headerArr(1, i) = rs.Fields(j).Name
j = j + 1
Next
getRecordHeaders = headerArr
Else
MsgBox "Error: Recordset is empty"
Stop
Exit Function
End If
End Function
This is how I would do it, to get all field naems and all records as well.
Sub ADOExcelSQLServer()
' Carl SQL Server Connection
'
' FOR THIS CODE TO WORK
' In VBE you need to go Tools References and check Microsoft Active X Data Objects 2.x library
'
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 rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Server_Name = "Your_Server_NameS" ' Enter your server name here
Database_Name = "Your_DB_Name" ' Enter your database name here
User_ID = "" ' enter your user ID here
Password = "" ' Enter your password here
SQLStr = "SELECT * FROM [Customers]" ' Enter your SQL here
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
For iCols = 0 To rs.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With Worksheets("sheet1").Range("a2:z500") ' Enter your sheet name and range here
'.ClearContents
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
I am writing a Excel file that can get a price form a database depending on 4 Criteria. I got to the point that it can find in one row the price (in the row there are first the 4 criteria and then the price)[See picture1]. but what i want is that every row can find the matching price. The code that i have now is this:
Option Explicit
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
With Worksheets("Summary")
strCriteriaEquipment = .Range("B29").Value
strCriteriaType = .Range("C29").Value
strCriteriaMaterial = .Range("D29").Value
strCriteriaSize = .Range("E29").Value
End With
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Call TableFetcher(strSQL)
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Option Explicit
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub Fetcher(strSQL As String, Optional strDropDownName As String)
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
With .DropDowns(strDropDownName)
.RemoveAllItems
.List = Split(UniqueStringWithDelimiter(rstRecordSet.GetRows, "|"), "|")
.Value = 1
End With
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
End Sub
Sub TableFetcher(strSQL As String)
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(5).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(5).Value = "Data Not Found!"
End If
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
How i do change the code so it does what i need it to do
What I think i'm reading is that, if four (4) criteria are met, you would then find a price. Have you used an If statement with AND modifier utilizing your four (4) criteria?
This could happen in a loop, such as:
Dim r as Long, c as Long, LR as Long
LR = Cells(Rows.Count,1).End(xlUp).Row 'Assumes column 1 is contiguous
For r = 1 to LR
c=4 'assumes you're starting with column 4
If Cells(r,c).Value="Blah" AND Cells(r,c+1).Value ="Moo" AND Cells(r,c+2).Value="Ruff" AND Cells(r,c+3).Value="Shamoo" Then
Cells(r,c+4).Copy
End If
Next r