Internet Sellout

Const ValueSheetName As String = "MyParamSheet"
Const ServerName As String = "ServerName"
Public Sub GetData()

	ThisWorkbook.Names("Results").RefersToRange.Value = "Getting..."
	Dim oWorksheet As Worksheet
	On Error Resume Next
	Set oWorksheet = ThisWorkbook.Worksheets(ValueSheetName)
	On Error GoTo 0
	If Not oWorksheet Is Nothing Then
		If Not Len(ThisWorkbook.Names("ListName").RefersToRange.Value) = 0 Then
			ThisWorkbook.Names("Results").RefersToRange.Value = GetItems(ThisWorkbook.Names("ListName").RefersToRange.Value, ThisWorkbook.Names("DateName").RefersToRange.Value, ThisWorkbook.Names("ValueName").RefersToRange.Value)
			Exit Sub
		End If
	End If
	MsgBox ("Need " & ValueSheetName & " sheet with first column list of values!")
End Sub
Public Function ConCatEndBlank(Delimiter As Variant, ParamArray CellRanges() As Variant) As String

	Dim Cell As Range, Area As Variant
	ConCatEndBlank = ""
	For Each Area In CellRanges
		If TypeName(Area) = "Range" Then
			For Each Cell In Area
				If Len(Cell.Value) > 0 Then
					ConCatEndBlank = ConCatEndBlank & Delimiter & Cell.Value
				Else
					Exit For
				End If
			Next
		Else
			ConCatEndBlank = ConCatEndBlank & Delimiter & Area
		End If
	Next
	ConCatEndBlank = Mid(ConCatEndBlank, Len(Delimiter) + 1)
End Function
Public Function GetItems(sList As String, dDate As Date, sValue As String) As Integer
	GetItems = 0
	If sList = "" Then
		GetItems = -1
	Else
		On Error GoTo Error1
		If sList = "All" Then sList = ""
		Dim oConn As New ADODB.Connection
		oConn.ConnectionString = "Provider=SQLOLEDB;Data Source=" & ServerName & ";Initial Catalog=DataBaseName;"
		Dim oCmd As New ADODB.Command
		oCmd.CommandType = adCmdStoredProc
		oCmd.NamedParameters = True
		oCmd.CommandText = "mystoredprocedure"
		oCmd.Parameters.Append oCmd.CreateParameter("@list", adVarChar, adParamInput, 2147483647, sList)
		oCmd.Parameters.Append oCmd.CreateParameter("@date", adDate, adParamInput, -1, dDate)
		oCmd.Parameters.Append oCmd.CreateParameter("@value", adVarChar, adParamInput, 8, sValue)
		oConn.Open
		Set oCmd.ActiveConnection = oConn
		Dim oRS As New ADODB.Recordset
		oRS.Open oCmd
		Dim oTarget As ListObject
		Dim oWorksheet As Worksheet
		On Error Resume Next
		Set oWorksheet = ThisWorkbook.Worksheets("QueryResults")
		On Error GoTo Error1
		If oWorksheet Is Nothing Then
			Set oWorksheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))oWorksheet.Name = "QueryResults"
		End If
		On Error Resume Next
		Set oTarget = oWorksheet.ListObjects("QueryData")
		On Error GoTo Error1
		If oTarget Is Nothing Then
			Set oTarget = oWorksheet.ListObjects.Add(xlSrcExternal, oRS, True, xlNo, oWorksheet.Range("A1"))
			oTarget.Name = "QueryData"
		Else
			Set oTarget.QueryTable.Recordset = oRS
		End If
		If Not oTarget Is Nothing Then
			Call oTarget.QueryTable.Refresh(False)
			GetParts = oTarget.ListRows.Count
		End If
		oRS.Close
		oConn.Close
		Set oRS = Nothing
		Set oConn = Nothing
		Set oCmd = Nothing
	End If
	Exit Function
Error1:
	MsgBox (Err.Description)
	On Error Resume Next
	oRS.Close
	oConn.Close
	Set oRS = Nothing
	Set oConn = Nothing
	Set oCmd = Nothing
End Function