Home » excel » file – The best possible way to populate VBA

file – The best possible way to populate VBA

Posted by: admin May 14, 2020 Leave a comment


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.

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

I am checking for date in the beginning. That part is fine.

How to&Answers:

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

   For i = 0 To rs.Field.Count
       .Cells(1, i+1) = rs.Fields(i).Name

   .Cells(2, 1).CopyFromRecordset rs
End With

''Tidy up
Set rs=Nothing
Set cn=Nothing


You could use a dictionary. Here is some pseudo code that can get you started.

  If range = storageName then
    if within the date range then
        If not dictionary.exists(storageName) then dictionary.add storageName
        dictionary(storageName) =     dictionary(storageName) + quantity

Now you only have to loop through the cells once.


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)))
                    '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