VBA Auto calculate and combine a list

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
154
Office Version
  1. 365
Platform
  1. Windows
Hi

I have a list of products where i would like to calculate the dublets into one line.

is it possible to do this with a macro / VBA ?

1628686029470.png


ProductDescription#
1702Product 1
200​
1702Product 1
300​
1702Product 1
200​
1702Product 1
400​
1900Product 20
80​
1900Product 20
90​
1900Product 20
60​
1900Product 20
40​
1900Product 20
12​
1900Product 20
18​
1900Product 20
20​
1900Product 20
30​
1984Product 123
125​
1984Product 123
100​
1984Product 123
75​
1984Product 123
200​
1984Product 123
100​
1984Product 123
90​
1984Product 123
110​
1984Product 123
100​
3620Product 1204
10​
3622Product 1205
20​
3630Product 1206
30​
3632Product 1207
40​
3664Product 1208
50​
3710Product 1209
60​
3720Product 1210
70​
3721Product 1211
80​
3722Product 1212
90​
 

Attachments

  • 1628685953280.png
    1628685953280.png
    49.1 KB · Views: 5

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Would I be correct in thinking that you will only have one description for each product?
Also roughly how many rows of data do you have?
 
Upvote 0
Would I be correct in thinking that you will only have one description for each product?
Also roughly how many rows of data do you have?
Yes, only one description.
If the same oroduct appears several times, it should be combined down to one row and calculated.

The list varies in size, but normaly it would be between 75 and up to 250 rows.

Pivot is not an option. For several reason this should be solved with VBA.
 
Upvote 0
Assuming data in columns A:C try this macro (results in columns F:H)

VBA Code:
Sub aTest()
    Dim dic As Object, vData As Variant
    Dim i As Long, arrAux As Variant
    Dim vKey As Variant, lLin As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(1) = arrAux(1) + vData(i, 3)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3))
        End If
    Next
    'Headers in F1:H1
    Range("F1:H1").Value = Range("A1:C1").Value
    lLin = 1
    For Each vKey In dic.keys
        lLin = lLin + 1
        Range("F" & lLin) = vKey
        Range("G" & lLin).Resize(, 2) = dic(vKey)
    Next vKey
    Columns("G").AutoFit
End Sub

M.
 
Upvote 0
Assuming data in columns A:C try this macro (results in columns F:H)

VBA Code:
Sub aTest()
    Dim dic As Object, vData As Variant
    Dim i As Long, arrAux As Variant
    Dim vKey As Variant, lLin As Long
  
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(1) = arrAux(1) + vData(i, 3)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3))
        End If
    Next
    'Headers in F1:H1
    Range("F1:H1").Value = Range("A1:C1").Value
    lLin = 1
    For Each vKey In dic.keys
        lLin = lLin + 1
        Range("F" & lLin) = vKey
        Range("G" & lLin).Resize(, 2) = dic(vKey)
    Next vKey
    Columns("G").AutoFit
End Sub

M.
Thanks.!
Looks like it works fine.

But... :)
If i run some lists with different amount of rows, there is some "remaining" text in the second column without data in the 1. and 3. column.

How to delete the rows below the current list (rows from previous lists) ?

ProductDescription#
1702Product 1200
1703Product 2300
1704Product 3200
1705Product 4400
1901Product 580
1902Product 690
1903Product 760
1904Product 840
1905Product 912
1906Product 1018
Product 11
Product 12
Product 13
Product 14
 
Last edited:
Upvote 0
Using your original example here is an alternative solution using Power Query

Power Query:
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Grouped Rows" = Table.Group(Source, {"Product", "Description"}, {{"Total", each List.Sum([#"#"]), type any}})
in
    #"Grouped Rows"
 
Upvote 0
Assuming data in columns A:C try this macro (results in columns F:H)

VBA Code:
Sub aTest()
    Dim dic As Object, vData As Variant
    Dim i As Long, arrAux As Variant
    Dim vKey As Variant, lLin As Long
   
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(1) = arrAux(1) + vData(i, 3)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3))
        End If
    Next
    'Headers in F1:H1
    Range("F1:H1").Value = Range("A1:C1").Value
    lLin = 1
    For Each vKey In dic.keys
        lLin = lLin + 1
        Range("F" & lLin) = vKey
        Range("G" & lLin).Resize(, 2) = dic(vKey)
    Next vKey
    Columns("G").AutoFit
End Sub

M.
Hi Marcelo

Is it possible to add a filter to column C ?
I only wanna see what´s above 0

THanks.
 
Upvote 0
Try to provide Data sample and expected results.

Use xl2bb (picture is not helpful)

M.
 
Upvote 0
Try to provide Data sample and expected results.

Use xl2bb (picture is not helpful)

M.


Product 1901 and 1904 should be filtered out
Product #TextQuantity
1702Product 1200
1703Product 2300
1704Product 3200
1705Product 4400
1901Product 50
1902Product 690
1903Product 760
1904Product 80
1905Product 912
1906Product 1018
Product 11
Product 12
Product 13

VBA Code:
Sub Liste_til_Indkoeb()

Dim lngColCounter As Long
Dim blnAddToData As Boolean

blnAddToData = False       'True: add data to bottom
                           'False: write new block
If Not blnAddToData Then
  Columns("AO:AO").ClearContents
  Columns("AQ:AQ").ClearContents
End If

Range("AO1").value = "Varenr.:"
Range("AQ1").value = "Antal:"

'Varenumre
For lngColCounter = 17 To 27
' 17=Q  27=AA
If Application.WorksheetFunction.CountA(Range(Cells(1, lngColCounter), Cells(Rows.Count, lngColCounter).End(xlUp))) > 0 Then
    With Range(Cells(2, lngColCounter), Cells(Rows.Count, lngColCounter).End(xlUp))
      Cells(Rows.Count, 41).End(xlUp).Offset(1, 0).Resize(.Rows.Count, 1).value = .value
      ' 17 To 27 = antal kolonner til højre
      ' Cells(Rows.Count, 39) = indsæt data 39 kolonner til højre
    End With
  End If
Next lngColCounter

'Antal
For lngColCounter = 29 To 39
' 29=AC  39=AM
If Application.WorksheetFunction.CountA(Range(Cells(1, lngColCounter), Cells(Rows.Count, lngColCounter).End(xlUp))) > 0 Then
    With Range(Cells(2, lngColCounter), Cells(Rows.Count, lngColCounter).End(xlUp))
      Cells(Rows.Count, 43).End(xlUp).Offset(1, 0).Resize(.Rows.Count, 1).value = .value
      ' 29 To 39 = antal kolonner til højre
      ' Cells(Rows.Count, 41) = indsæt data 41 kolonner til højre
    End With
  End If
Next lngColCounter
'End Sub

  Columns("A:C").ClearContents

'KOMBINER OG BEREGN DATA FRA LISTEN OG INDSÆT DEM I KOLONNE A-C
    Dim dic As Object, vData As Variant
    Dim i As Long, arrAux As Variant
    Dim vKey As Variant, lLin As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    vData = Range("AO2:AQ" & Cells(Rows.Count, "AO").End(xlUp).Row)
    For i = 1 To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(1) = arrAux(1) + vData(i, 3)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3))
        End If
    Next
    'Headers in A1:C1
    Range("A1:C1").value = Range("AO1:AQ1").value
    lLin = 1
    For Each vKey In dic.keys
        lLin = lLin + 1
        Range("A" & lLin) = vKey
        Range("B" & lLin).Resize(, 2) = dic(vKey)
    Next vKey
    
    'Columns("B").AutoFit
    ' VIRKER IKKE NÅR ARKET ER LÅST


' SORTER DATA EFTER VARENUMMER
    Columns("A:C").Select
    ActiveWorkbook.Worksheets("Liste til Indkøb").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Liste til Indkøb").Sort.SortFields.Add2 Key:=Range _
        ("A2:A412"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Liste til Indkøb").Sort
        .SetRange Range("A1:C412")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Range("A1").Select

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,947
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top