VBA - need a little help to change output destination for existing macro

smide

Board Regular
Joined
Dec 20, 2015
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
Hello.


I'm not really familiar with VBA code and I'll appreciate some help here.


I'm using this macro to SUM previous six values for my Product's (text cells) in columns A and B (A2:A600 and B2:B600).
So Products are in columns A and B and their values are in columns C and D.


When Product is in column A his value is in the same row in column C, and when Product is in column B his value is in the same row but now in column D.


Finally, after this 'original' macro run outputs/results (SUM of previous six values for each Product) are placed in columns E and F (the same row where referent Product appears).

Macro:

Code:
Sub sum()
On Error Resume Next
Dim Rng As Range, Dn As Range, n As Long, K As Variant, R As Range, c As Long, Tot As Long
Dim temp As Long, V As Range, fD As Boolean
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Dn
    Else
        Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
End If
Next
Dim t
For Each K In .keys
    For Each V In .Item(K)
        c = 0: Tot = 0: temp = 0
        For Each R In .Item(K)
            If R.Address = V.Address Then fD = True
                If fD Then
                    If c = 0 And temp <> 0 Then
                        R.Offset(, 4).Value = temp: temp = 0
                        fD = False: Exit For
                    End If
                        c = c + 1
                        Tot = Tot + R.Offset(, 2).Value
                    
                    If c = 6 Then
                        temp = Tot
                        c = 0: Tot = 0
                    End If
                End If
        Next R
    Next V
Next K
End With
End Sub

I would like to do the following changes in this 'original' macro:


- Instead of columns A and B I want to change search area for my Product's list in columns C and D
- Instead of columns C and D where my current values for Products are I want to change search area for them (values) in columns S and T
- Results are placed now in columns E and F but I want to change this also and to place results in columns BL and BM


I'll really appreciate some short explanation about changes done in code (if possible) so that I could adjust code next time if necessary.
 
Last edited:

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Hello,

There are only a few tiny modifications required to be in line with your new worksheet structure ...
Code:
Sub NewSumPrevious6()


' Sum Previous 6 Values


On Error Resume Next


Dim Rng As Range, Dn As Range, n As Long, K As Variant, R As Range, c As Long, Tot As Long
Dim temp As Long, V As Range, fD As Boolean


Set Rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp)).Resize(, 2)
With CreateObject("scripting.dictionary")
  .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        End If
    Next Dn
    
    For Each K In .keys
        For Each V In .Item(K)
            c = 0: Tot = 0: temp = 0
            For Each R In .Item(K)
                If R.Address = V.Address Then fD = True
                    If fD Then
                        If c = 0 And temp <> 0 Then
                            R.Offset(, 61).Value = temp: temp = 0
                            fD = False: Exit For
                        End If
                            c = c + 1
                            Tot = Tot + R.Offset(, 16).Value
                        If c = 6 Then
                            temp = Tot
                            c = 0: Tot = 0
                        End If
                    End If
            Next R
        Next V
    Next K
End With
End Sub

Hope this will help
 
Upvote 0
Hello,

There are only a few tiny modifications required to be in line with your new worksheet structure ...
Code:
Sub NewSumPrevious6()


' Sum Previous 6 Values


On Error Resume Next


Dim Rng As Range, Dn As Range, n As Long, K As Variant, R As Range, c As Long, Tot As Long
Dim temp As Long, V As Range, fD As Boolean


Set Rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp)).Resize(, 2)
With CreateObject("scripting.dictionary")
  .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        End If
    Next Dn
    
    For Each K In .keys
        For Each V In .Item(K)
            c = 0: Tot = 0: temp = 0
            For Each R In .Item(K)
                If R.Address = V.Address Then fD = True
                    If fD Then
                        If c = 0 And temp <> 0 Then
                            R.Offset(, 61).Value = temp: temp = 0
                            fD = False: Exit For
                        End If
                            c = c + 1
                            Tot = Tot + R.Offset(, 16).Value
                        If c = 6 Then
                            temp = Tot
                            c = 0: Tot = 0
                        End If
                    End If
            Next R
        Next V
    Next K
End With
End Sub

Hope this will help

Yes I got it, changing columns number in offset function.


Currently this macro SUM previous six values following this rules:
- when Product is in column C his value is in the same row in column S
- when Product is in column D his value is in the same row but now in column T


Suppose I need to SUM also previous six values but this time values from opposite columns eg. :
- when Product is in column C his value is in the same row but now in column T
- when Product is in column D his value is in the same row but now in column S


Do you have any idea how to modify existing macro according to these new requirements?
 
Upvote 0

Forum statistics

Threads
1,213,507
Messages
6,114,029
Members
448,543
Latest member
MartinLarkin

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