VBA modification

231tony231

New Member
Joined
Sep 11, 2014
Messages
1
Hi,
i'm quite a beginner with VBA and i found a code that almost does what i need. Basicly i need to find the duplicate in colum "A", sum the Qty of the duplicate with are in colum "B" and i would like to be able to copy some or the remaining colum without summing them since they are description.

Here is the actual code:

Code:
[FONT=Courier New]       
  Dim Cell As Range
  Dim Data() As Variant
  Dim DSO As Object
  Dim DSO_c As Object                                   '
  Dim Key As Variant
  Dim Keys As Variant
  Dim I As Long
  Dim Item As Variant
  Dim Item_c As Variant                                 '
  Dim Items As Variant
  Dim Items_c As Variant                                '
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SumWks As Worksheet
  Dim Wks As Worksheet
  
    On Error Resume Next
      Set SumWks = Worksheets("Summary Report")
        If Err = 9 Then
           Err.Clear
           Worksheets.Add.Name = "Summary Report"
           Set SumWks = ActiveSheet
             Cells(1, "A") = "Investment"
             Cells(1, "B") = "Total Amount"
             Cells(1, "C") = "Total Amount"             '
             Rows(1).Font.Bold = True
             Columns("A:C").AutoFit
        End If
    On Error GoTo 0
    
    Set DSO = CreateObject("Scripting.Dictionary")
    Set DSO_c = CreateObject("Scripting.Dictionary")    '
    DSO.CompareMode = vbTextCompare
    DSO_c.CompareMode = vbTextCompare                   '
    
      For Each Wks In Worksheets
        If Wks.Name <> SumWks.Name Then
           Set Rng = Wks.Range("A1")
           Set RngEnd = Rng.Cells(Rows.Count, Rng.Column).End(xlUp)
           Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
             For Each Cell In Rng
               Key = Trim(Cell.Value)
               Item = Cell.Offset(0, 1).Value
               Item_c = Cell.Offset(0, 2).Value         '
               If Key <> "" Then
                 If Not DSO.Exists(Key) Then
                    DSO.Add Key, Item
                    DSO_c.Add Key, Item_c               '
                 Else
                    DSO(Key) = DSO(Key) + Item
                    DSO_c(Key) = DSO_c(Key) + Item_c      '
                 End If
               End If
             Next Cell
        End If
      Next Wks
      
      With SumWks
        .UsedRange.Offset(1, 0).ClearContents
        Keys = DSO.Keys
        Items = DSO.Items
        Items_c = DSO_c.Items                           '
          For I = 0 To DSO.Count - 1
            .Cells(I + 2, "A") = Keys(I)
            .Cells(I + 2, "B") = Items(I)
            .Cells(I + 2, "C") = Items_c(I)             '
          Next I
        .UsedRange.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
                        Header:=xlYes, Orientation:=xlSortColumns
      End With
    
    Set DSO = Nothing
  Set DSO_c = Nothing                                 '
    
End Sub[/FONT]
thx in advance !!!</PRE>
 
Last edited:

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

Forum statistics

Threads
1,222,143
Messages
6,164,171
Members
451,880
Latest member
2da

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