Related
Every morning I have to compare manually row by row the information in my database with the one sent by the broker. Normally they should have exactly the same information.
The information is about executed trades.
1- I need to compare row by row looking at the values "Stock", "Qty", "Price" and "Date". If any row is not matched from each other (i.e. a value is erroneously different in one of the table or the entire row is missing), I need the unmatched rows to be printed in a third "OUTPUT" table.
My TABLE, BROKER'S TABLE & OUTPUT
2- The thing here is that there are duplicates like for "microsoft" or "nvidia" that are independent trades (different IDs). Duplicates must be kept in the comparison because they are different trades.
How could I manage the duplicates problems? Using Collections in Dictionary could help me? I would compare Table A to Table B and then Table B to Table A.
Or the presence of duplicates (actually independent trades) makes it impossible to perform ?
My file has more than 500 rows.
I'll add an entirely in-memory way to achieve the output.
The one thing worth considering is that we have no way of differentiating one ID from the next if they have matching stock, price, qty, and dates. So, the way I'm handling duplicates is in the order that they appear in the spreadsheet. So if there are two matching entries in your table, and only 1 in the broker table, I assume that the first entry in your table matches the first entry in the broker table, and therefore your second entry will be output.
Try working through the code. I took a few shortcuts for the sake of timing, but I also encapsulated each of the functions so that you can modify as needed. You'll just have to build out the DeserializeKey function to convert a key back to cells in the output sheet (shouldn't be too hard). See the below code, and let me know if it meets expectations.
Note: You will run the "CompareDictionaries" subroutine. The others are helper functions.
Sub CompareDictionaries()
Dim oMine As Object
Dim oBroker As Object
Dim myQueueCount As Long
Dim brokerQueueCount As Long
Dim minQueue As Long
Dim oMinQueue As Object
Set oMine = GetDictionary(Sheet1.Range("A2:E7"))
Set oBroker = GetDictionary(Sheet2.Range("A2:E6"))
For Each oKey In oMine.keys
'The whole row does not exist in the broker table
If Not oBroker.Exists(oKey) Then
Do While oMine(oKey).Count > 0
DeserializeKey oKey, oMine(oKey).dequeue
Loop
Else 'The keys exist in both tables
myQueueCount = oMine(oKey).Count
brokerQueueCount = oBroker(oKey).Count
If myQueueCount = brokerQueueCount Then
'Do nothing. They both have the same number of
'id's, and so we assume they are in sync.
Else
'Determine the minimum queue size, and get rid
'of that many values, since we won't need them
minQueue = IIf(myQueueCount < brokerQueueCount, myQueueCount, brokerQueueCount)
For i = 1 To minQueue
oMine(oKey).dequeue
oBroker(oKey).dequeue
Next i
'Take the remaining IDs out of the dictionary/queue that had more
If brokerQueueCount > myQueueCount Then
Set oMinQueue = oBroker
Else
Set oMinQueue = oMine
End If
Do While oMinQueue(oKey).Count > 0
DeserializeKey oKey, oMinQueue(oKey).dequeue
Loop
End If
End If
Next oKey
'The only remaining thing to test for is keys in the broker dict
'that are not in the myDict
For Each oKey In oBroker.keys
If Not oMine.Exists(oKey) Then
Do While oBroker(oKey).Count > 0
DeserializeKey oKey, oBroker(oKey).dequeue
Loop
End If
Next oKey
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Set sht = inputRange.Parent
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
If oDict.Exists(theKey) Then
oDict(theKey).enqueue cel.Value
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue cel.Value
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
Sub DeserializeKey(ByVal theKey As String, theId As String)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Debug.Print theId & " " & theKey
End Sub
Function GenerateKey(rng As Range) As String
GenerateKey = rng(2) & Format(rng(3), "0") _
& Format(rng(4), "0.00") & Format(rng(5), "mmddyyyy")
End Function
For those interested in this method, I'm editing this answer to add the "deserializekey" function:
Dim r As Long
Worksheets("Output").Activate
r = 1
'What we are doing here with "loopcell" is to check if the destination cells in the "output" sheet are empty or free.
'If not, we go down 1 row.
loopcell:
If IsEmpty(Range("A" & r).Value) = True Then
Range("A" & r).Value = "_" & theId & "_" & theKey
Else
r = r + 1
GoTo loopcell
End If
'The key is wrote to the the cell but we need to split every element of the key in multiple cells.
splitOutput = Range("A" & r).Value
splitArray = Split(splitOutput, "_")
For i = 1 To UBound(splitArray)
Cells(r, i).Value = splitArray(i)
Next i
Debug.Print theId & " " & theKey
End Sub ```
** New GetDictionary and Deserialize methods used to store more info **
Sub DeserializeKey(ByVal theKey As String, theId As Variant)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Dim output As String
'Keep in mind that we have a 2d array, and we are reading
'one row at a time. So get the number of columns in the
'array, and then do whatever you need with them.
For i = LBound(theId, 2) To UBound(theId, 2)
output = output & " " & theId(1, i)
Next i
Debug.Print theKey & " -->" & output
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Dim columnCount As Long
Dim rngAsArray As Variant
Set sht = inputRange.Parent
'Get the column count of the input range. Since we don't
'hardcode it in, this function is more flexible to
'future changes
columnCount = inputRange.Columns.Count
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
'Put the full row into an array, which we will then
'store as the content of the queue
rngAsArray = cel.Resize(, columnCount).Value
If oDict.Exists(theKey) Then
oDict(theKey).enqueue rngAsArray
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue rngAsArray
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
First of all, please read DS_London's comment.
If you would like to have a result sheet, then you can use below macro:
Option Explicit
Sub CompareData()
Dim wbk As Workbook
Dim wshMyData As Worksheet, wshBrokersData As Worksheet, wshResult As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim sTmp As String
On Error Resume Next
Set wbk = ThisWorkbook
Set wshResult = wbk.Worksheets("Result")
On Error GoTo Err_CompareData
'if there_s no result sheet
If Not wshResult Is Nothing Then
Application.DisplayAlerts = False
wbk.Worksheets("Result").Delete
Application.DisplayAlerts = True
End If
Set wshMyData = wbk.Worksheets("Sheet1")
Set wshBrokersData = wbk.Worksheets("Sheet2")
Set wshResult = wbk.Worksheets.Add(After:=wshBrokersData)
wshResult.Name = "Result"
wshResult.Range("A1") = "ID"
wshResult.Range("B1") = "Stock"
wshResult.Range("C1") = "Qty"
wshResult.Range("D1") = "Price"
wshResult.Range("E1") = "Date"
wshResult.Range("F1") = "My"
wshResult.Range("G1") = "Broker"
wshResult.Range("A1:G1").Interior.Color = vbGreen
'find last entry in your data
i = wshMyData.Range("A" & wshMyData.Rows.Count).End(xlUp).Row
'find last entry in brokers data
j = wshBrokersData.Range("A" & wshBrokersData.Rows.Count).End(xlUp).Row
'copy data into result sheet
k = 2
wshMyData.Range("A2:E" & i).Copy wshResult.Range("A" & k)
k = k + i - 1
wshBrokersData.Range("A2:E" & j).Copy wshResult.Range("A" & k)
k = k + j - 2
'remove duplicates
wshResult.Range("$A$1:$E$" & k).RemoveDuplicates Columns:=Array(2, 3, 4, 5), Header:=xlYes
k = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
'start comparison ;)
'my data
sTmp = "(" & wshMyData.Name & "!" & wshMyData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("F2").BorderAround LineStyle:=xlContinuous
wshResult.Range("F2").FormulaArray = sTmp
wshResult.Range("F2:F" & k).FillDown
'brokres data
sTmp = "(" & wshBrokersData.Name & "!" & wshBrokersData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("G2").BorderAround LineStyle:=xlContinuous
wshResult.Range("G2").FormulaArray = sTmp
wshResult.Range("G2:G" & k).FillDown
'autofit
wshResult.Range("A:G").Columns.AutoFit
Exit_CompareData:
On Error Resume Next
Set wshMyData = Nothing
Set wshBrokersData = Nothing
Set wshResult = Nothing
Set wbk = Nothing
Exit Sub
Err_CompareData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CompareData
End Sub
Result:
As you can see, 0 means that there's no corresponding data in selected sheet.
What above macro does?
Adds new sheet: Result, then adds column headers (ID, Stock, Qty, Price, Date, My data, Broker in row 1 respectively in columns A-G)
Copies all data from your sheet (Sheet1) to Result sheet
Copies all data from broker's sheet (Sheet2) to Result sheet
Removes duplicates in Result sheet (based on all columns excluding ID)
Inserts formula-array in cell F2 and G2 and fill it down.
Important note: There's at least few other ways to achieve that...
Final note: Feel free to change the code to your needs.
I am just wondering how i can skip over an error if the array is not full? For example, 1 loop goes over whether the array has a first and last name, if there is no last name i would like the script to continue.
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
For intCount = LBound(Name) To UBound(Name)
sData.Range("C" & iii).Value = Name(0)
sData.Range("D" & iii).Value = Name(1)
Next
If Name(1) is empty then how can the code continue?
Since the two columns are consecutive, you can just paste the array in-place, using Range.Resize to dump the array across as many columns as needed - the only thing to watch for is if Name can contain more than a single space:
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
If UBound(Name) <= 1 Then
sData.Range("C" & iii).Resize(, UBound(Name) + 1).Value = Name
Else
'there was more than one space...
End If
If you want to avoid using On Error Resume Next, you can try this:
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
If Len(Join(Name)) > 0 Then
sData.Range("C" & iii).Value = Name(0)
sData.Range("D" & iii).Value = Name(1)
End If
which was originally posted here. Join essentially reverts to the FullName value but without the space. Alternatively, you could just use If InStr(1, FullName, " ", vbBinaryCompare) > 0 Then.
With some test values
Option Explicit
Sub test()
Dim ii As Long
Dim iii As Long
ii = 2
iii = 3
Dim FullName As String
Dim Name() As String
With ActiveSheet
FullName = .Cells(37, ii).Value
If InStrRev(FullName, " ", -1) > 0 Then 'space present
Name = Split(FullName, " ")
If UBound(Name) > 1 Then Exit Sub 'there was more than one space present. Handling this was not specified so exit sub.
.Range("C" & iii).Value = Name(0)
.Range("D" & iii).Value = Name(1)
Else
.Range("C" & iii).Value = FullName
.Range("D" & iii).Value = vbNullString
End If
End With
End Sub
I am having trouble with an asp page that contains a random function to display a random number of random records. The way I have the code now, as shown below, nothing appears on the page even though there are several records that match the criteria.
Out of 500 records I have in my database, about 70 match the criteria, but form some reason, they never seem to fall within the plist variable, to be used in the query.
When I change the max number to a lower number, say 10, I get an error message that the EOF has been found or no more records are available. Using debugging code, I couldnt find anything out of the ordinary, just the fact that from all the 100 records input into the plist, none of them match the records from the main criteria.
I am posting the entire code here. Maybe someone can catch what may be causing to not work properly.
Sub GetRandomDomains
dim conn, maxrecords, count, webname
dim randomrs, sql
'If (conn.State = adStateClosed) Then
OpenDB conn
'End If
count=0
maxrecords=100
KeywordColumnGetRandomKeywords conn, maxrecords, sql
If sql="" then
conn.close
set conn=nothing
Response.Write(" NOT AVAILABLE")
exit sub
end if
set randomrs=conn.execute(sql)
Response.Write("<ul id='catnav'>")
do While Not randomrs.EOF and count<maxrecords
If isnull(randomrs("sitename")) Then
webname=randomrs("domain")
Else
webname=randomrs("sitename")
End if
Response.Write "<li> " & webname &"</li>"
count=count+1
randomrs.movenext
loop
Response.Write("</ul>")
CloseSet randomrs
CloseDB conn
end sub
Sub KeywordColumnGetRandomKeywords (conn,maxrecords,sql)
dim i, id, index, plist, rs, sqlstr, sortstr
plist=""
Set rs=Server.CreateObject("ADODB.Recordset")
sqlstr="SELECT domainid FROM domains"
sqlstr=sqlstr
Debugwrite sqlstr, "sqlstr for random domains"
rs.Open sqlstr,conn,3,3
If rs.eof then
CloseSet rs
Response.Write(" EMPTY")
sql=""
exit sub
end if
Debugwrite rs("domainid"), "rs for random domains"
Dim arrData ' Array to Store Data
Dim arrSequence ' Array to Hold Random Sequence
Dim iArrayLooper ' Integer for Looping
Dim iarraysize ' Size of Data Array
If xdbasetype="Local" Then
iarraysize=cint(rs.recordcount)
else
iarraysize=cint(GetRecordcount (conn))
end if
Debugwrite GetRecordcount(conn), "getrecordcount for random domains array"
Debugwrite(IsArray(iarraysize)), "random domains count array"
'if (cint(GetRecordcount(conn)))= 0 or isnull(cint(GetRecordcount(conn))) then
'Exit Sub
'End if
redim arrdata(cint(iarraysize))
for i = 0 to iarraysize-1
arrData(i)=rs(0)
rs.movenext
next
rs.close
Set rs = Nothing
If iarraysize<maxrecords then
maxrecords=iarraysize
end if
' Get an array of numbers 0 to array size randomly sequenced.
arrSequence = Resequencearray(iArraySize)
for i = 0 to maxrecords-1
index=arrsequence(i)
id=arrdata(index)
if plist<>"" then
plist=plist & ","
end if
plist=plist & id
Next
sql="select domainid, domain, sitename,sitematch,altmatch from domains"
sql = sql & " WHERE restricted=0 and(sitematch like '%" & xsitematch & "%' or altmatch like '%" & xaltmatch & "%')"
sql = sql & " and domainid In (" & plist & ") "
Debugwrite sql, "first sql for random domains"
end sub
Function ResequenceArray(iArraySize)
Dim arrTemp()
Dim I
Dim iLowerBound, iUpperBound
Dim iRndNumber
Dim iTemp
' Set array size
ReDim arrTemp(iArraySize - 1)
Randomize
iLowerBound = LBound(arrTemp)
iUpperBound = UBound(arrTemp)
For I = iLowerBound To iUpperBound
arrTemp(I) = I
Next
' Loop through the array once, swapping each value
' with another in a random location within the array.
For I = iLowerBound to iUpperBound
iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1))
' Swap Ith element with iRndNumberth element
iTemp = arrTemp(I)
arrTemp(I) = arrTemp(iRndNumber)
arrTemp(iRndNumber) = iTemp
Next 'I
' Return our array
ResequenceArray = arrTemp
End Function
'***********************************************************************
' get record count for mysql
'************************************************************************
Function GetrecordCount(conn)
dim sqlstr, rs, rcount
sqlstr="select count(domainid) FROM domains WHERE restricted=0 and (domaingroup='" & xdomaingroup & "' or altmatch like '%" & xaltmatch & "%')"
Debugwrite sqlstr, "sqlstr for random domains"
set rs=conn.execute(sqlstr)
if rs.eof then
rcount=0
else
rcount=rs(0)
end if
CloseSet rs
Getrecordcount=cint(rcount)
Debugwrite rcount, "getrecordcount for random domains"
End function
Okay. There may be a far more simple way of approaching this. Here's a piece of code that gets the data as an array - far simpler and we have much more control over what's in it...
'Constants relating to the following routines...
const C_NO_DATA = "NO_DATA" 'Used when no data is returned to a consuming routine
const C_ERROR = "ERROR" 'Used when an error is generated
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent.
' connString (string) - The database connection string.
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
function GetDataSet(sqlString, connString)
'Initialise...
dim returnVal, rsData
on error resume next
'Define and open the recordset object...
set rsData = Server.CreateObject("ADODB.RecordSet")
rsData.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim returnVal(0,0)
returnVal(0,0) = C_NO_DATA
'Deal with any errors...
if not rsData.EOF and not rsData.BOF then
'Store the data...
returnVal = rsData.GetRows()
'Tidy up...
rsData.close
set rsData = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim returnVal(4,0)
returnVal(0,0) = C_ERROR
returnVal(1,0) = err.number
returnVal(2,0) = err.description
returnVal(3,0) = sqlString
returnVal(4,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
Okay, so we read the data we're after into an array. Note that I don't know where your xaltmatch and xsitematch variables come from so you'll need to supply these at some point...
Dim ds, sql
sql = _
"SELECT " & _
"domainid, " & _
"domain, " & _
"sitename, " & _
"sitematch, " & _
"altmatch " & _
"FROM " & _
"domains " & _
"WHERE " & _
"restricted=0 AND " & _
"(sitematch LIKE '%" & xsitematch & "%' OR " & _
"altmatch LIKE'%" & xaltmatch & "%') AND " & _
"domainid IN (" & plist & ") "
ds = GetDataSet(sql, conn)
The ds variable now contains an array of elements pulled from the database. All we need to do now is loop through the required number of times...
dim row, rows, used, randoms, col, cols, rc, cc
rows = UBound(ds, 2) 'Get the upper bound of the second array dimension
cols = UBound(ds, 1) 'Get the number of columns for writing to the page
randoms = 70 'Total number of randoms we need
used = ","
for rc = 1 to randoms
'Just in case we don't want to repeat the same row...
do
row = int(rnd(1)*rows) 'Zero based - we don't need to add 1
until instr(used, "," & row & ",")) = 0
'Add our random row to the list...
used = used & row & ","
'Write our output to the page...
response.write("<table>")
for cc = 0 to cols
response.write("<tr>")
response.write("<td>")
response.write(ds(cc, row))
response.write("</td>")
response.write("</tr>")
next 'cc
response.write("</table>")
next 'rc
The GetDataSet code is part of my stock functions, so I know that works, but I will hold my hand up and say that I haven't tested the rest of it.
Have a bash with this one, Luis, and let me know how you get on.
I wrote an hta app that takes one search parameter.
With this search parameter, users can search by firstname, or lastname or both.
This works really well.
Today, management decided to add date range as part of the search.
I have tried to build the WHERE clause where a user can search with lastname, first name or both OR date range but not both.
In other words, on the one hand, users can search by lastname, first name or both using a form variable called txtsrch.
Or they can just use date range only using fromMDY as fromDate and toMDY as toDate.
So far, it isn't working out well.
Whether I enter a search into the name search box or I select a date range, I get type mismatch error.
I wasn't getting type mismatch error when it was just a searchbox only.
Any assistance is greatly appreciated.
This is minimal, I think relevant code.
Date is in the form of 1/1/2013
'*
Const cOPT = "<option value='?'>?</option>"
'*
Dim fromMDY(2)
Dim toMDY(2)
Dim optMDY(2)
optMDY(0) = "<option value='0'></option>"
optMDY(1) = "<option value='0'></option>"
optMDY(2) = "<option value='0'></option>"
Dim i
'*
For i = 1 To 12
optMDY(0) = optMDY(0) & vbCrLf & Replace(cOPT,"?",i)
Next
For i = 1 To 31
optMDY(1) = optMDY(1) & vbCrLf & Replace(cOPT,"?",i)
Next
For i = Year(Date)+1 To Year(Date)-4 Step -1
optMDY(2) = optMDY(2) & vbCrLf & Replace(cOPT,"?",i)
Next
Sub Selected(What)
Select Case What
Case "FromMonth"
fromMDY(0) = FromMonth.Value
Case "FromDay"
fromMDY(1) = FromDay.Value
Case "FromYear"
fromMDY(2) = FromYear.Value
Case "ToMonth"
toMDY(0) = ToMonth.Value
Case "ToDay"
toMDY(1) = ToDay.Value
Case "ToYear"
toMDY(2) = ToYear.Value
End Select
End Sub
Sub DisplayDates()
MsgBox "From:" & vbTab & Join(fromMDY,"/") & vbCrlf _
& "To:" & vbTab & Join(toMDY,"/")
End Sub
' first: Do we use AND or OR between clauses in the WHERE?
' AndOr = ANDOR.value
Sub radiocheck()
for each b in ANDOR
if b.checked Then AndOr = b.Value
next
End Sub
' and now build up the WHERE:
where = ""
tsrch = txtsrch.Value
If tsrch <> "" Then
where = where & " Name = '" & Replace(tsrch,"'","''") & "'"
End If
If fromMDY <> "" AND toMDY<> "" Then
where = where & " convert(datetime, (left(dispdt,2) + '/' + substring(dispdt,3,2) + '/' + case when cast(right(dispdt,2) as int) >= 70 then '19' else '20' end + right(dispdt,2)), 101) Between '"& fromMDY &"' AND '"& toMDY &"' "
End If
'Take care of sql injection tactics
SQL_query = "SELECT TOP 1000 Name, Rel, Estno, dtfild, pub, [TYPE OF DOCUMENT] typeofdocument, btyp, bkno, disp, dispdt, PGNO FROM PCS60418_MTHLY_XREF WHERE " _
& where
msgBox sql_query
VBScript is Case Insensitive. ANDOR is exactly the same as AndOr so if you are doing this:
Sub radiocheck()
for each b in ANDOR
if b.checked Then AndOr = b.Value
next
End Sub
You are assigning a primitive to AndOr which conflicts with the ANDOR that is of type Array or Iteratable Object. Just rename one of the two variables and give it another try.
To prevent this kind of errors in the future: use Option Explicit, use correct (consistent) variable naming and use correct scoping: as locally as possible and passing variables to subroutines instead of using them as global variables.
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