Data define and search function request?
'wrote this with my 3 month old on my shoulder. needs reference to
adodb and error trapping etc...
Sub Crabtree()
Dim cd() As Variant
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sql, crt, crt1 As String
Dim i, t, k, j As Integer
Sheets("codes").Activate
Sheets("codes").Range("a1").Select
Range(Selection, Selection.End(xlDown)).Select
t = Selection.Rows.Count
startdate = InputBox("Enter Start Date: ")
enddate = InputBox("Enter End Date: ")
ReDim cd(1 To t)
Sheets("codes").Range("a1").Select
For i = 1 To t
cd(i) = Selection.Value
Selection.Offset(1, 0).Select
Next i
crt = "('" & cd(1)
For j = 2 To t - 1
crt1 = crt1 & "','" & cd(j)
Next j
crt = crt & crt1 & "')"
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & ActiveWorkbook.Path & "\" &
ActiveWorkbook.Name & ";Extended Properties=Excel 8.0; "
.Open
End With
sql = "select date as dt,code,sum(quantity) as Qt , sum(value) as Vl "
sql = sql & " from [data$]"
sql = sql & " where code in " & crt
sql = sql & " and date=#" & startdate & "# and date<=#" & enddate
sql = sql & "# group by date,code"
Set rs = New ADODB.Recordset
rs.Open sql, cn, adOpenStatic, adLockReadOnly, -1
Sheets("output").Activate
Sheets("output").Range("a1").Select
Selection.CurrentRegion.Select
Selection.ClearContents
Sheets("output").Cells(1, 1) = "Date"
Sheets("output").Cells(1, 2) = "Code"
Sheets("output").Cells(1, 3) = "Quantity"
Sheets("output").Cells(1, 4) = "Value"
rs.MoveFirst
For k = 0 To rs.RecordCount - 1
Sheets("output").Cells(k + 2, 1) = rs.Fields.Item(0).Value
Sheets("output").Cells(k + 2, 2) = rs.Fields.Item(1).Value
Sheets("output").Cells(k + 2, 3) = rs.Fields.Item(2).Value
Sheets("output").Cells(k + 2, 4) = rs.Fields.Item(3).Value
rs.MoveNext
Next k
End Sub
|