Running total that resets

[Lobsterboy1]

Hi, I am trying to find a way to automatically do some formulas that I currently do manually. I think the only way will be through VBA which I kind of understand but not enough to do this. This is what I have.

A B C D BOX
174a 100 mirror
174b 62 mirror
175a 51 51 A B
175b 33 84 B C
175c 1 85 C
178a 25 25 A
178b 21 46 A B
178c 52 98 B C D
178d 13 111 D
178e 11 122 D E
178f 17 139 E
178g 54 193 E F
178h 50 243 F G
178i 3 246 G
173 26 26 A
179a 60 60 A B
179b 57 117 C D
179c 60 177 D E F
179d 60 237 F G H
179e 26 263 H I
179f 4 267 I
179g 60 327 I J K
179h 59 386 K L M

Column A is a run number
Column B is the amount
Column C might have "Mirror" in if it does no formula is required
Column D is a running total of the run number, this resets when the run number changes. This column is not actually needed it just helps me to work the box letters out.
Column E is the box letters that the items go into, there are always 30 items per box

Columns A B and C are already on the worksheet, I make columns D and E with E being my final goal.

what I am after automatically doing is working out the box letters for the production runs, so in 175a there are 51 items so 30 will go in box A. Leaving 21 to go in box B. This means out of 175b 9 will go into box B to make it up to 30 and the remaining 24 will go into box C and so on through out the run, the last box might not be full which is fine. This starts again at 178a and carry's on down the list. If column C contains the text "MIRROR" i dont want anything in column E.

Is there a formula I could use to populate the box letters or is VBA the only way.

Thanks.

 

[MickG]

Try this :-
NB:- The results start in "R4".

[COLOR="Navy"]Sub[/COLOR] MG21May33
'[COLOR="Green"][B]new code 21/5/19[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, tot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRay() [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nTot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] y [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] M [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


[COLOR="Navy"]Set[/COLOR] Rng = Range("B4", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dn.Value = vbNullString [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not InStr(Dn.Offset(, 13).Value, "mirrored") > 0 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not .Exists(Left(Dn.Value, 3)) [COLOR="Navy"]Then[/COLOR]
                .Add Left(Dn.Value, 3), Dn.Offset(, 3)
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] .Item(Left(Dn.Value, 3)) = Union(.Item(Left(Dn.Value, 3)), Dn.Offset(, 3))
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
  tot = 0: Num = 65
  ReDim Ray(1 To Application.Sum(.Item(K)), 1 To 2)

  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
    [COLOR="Navy"]For[/COLOR] n = 1 To R.Value
        c = c + 1
        p = p + 1
        p = IIf(p Mod 31 = 0, 1, p)
        Ray(c, 1) = n: Ray(c, 2) = p
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] R

[COLOR="Navy"]Dim[/COLOR] vRay() [COLOR="Navy"]As[/COLOR] Variant
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
        y = y + 1
        ReDim Preserve vRay(1 To 2, 1 To y)
        vRay(1, y) = R
        vRay(2, y) = R.Address
    [COLOR="Navy"]Next[/COLOR] R


M = 1: c = 0
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Ray(n, 1) = vRay(1, M) [COLOR="Navy"]Then[/COLOR]
        M = M + 1
        G = G + 1
        ReDim Preserve nRay(1 To G)
        nRay(G) = Application.Min(Ray(n, 1), Ray(n, 2))
    [COLOR="Navy"]ElseIf[/COLOR] Ray(n, 2) = 30 [COLOR="Navy"]Then[/COLOR]
            G = G + 1
            ReDim Preserve nRay(1 To G)
            nRay(G) = Application.Min(Ray(n, 1), Ray(n, 2))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n

Num = 65: c = 0
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(vRay, 2)
    Ac = 13: tot = 0
        [COLOR="Navy"]Do[/COLOR] Until vRay(1, n) = tot
            c = c + 1
            tot = tot + nRay(c)
            Range(vRay(2, n)).Offset(, Ac) = Chr(Num) & " " & nRay(c)
            nTot = nTot + nRay(c)
            Ac = Ac + 1
            [COLOR="Navy"]If[/COLOR] nTot Mod 30 = 0 [COLOR="Navy"]Then[/COLOR] Num = Num + 1
        [COLOR="Navy"]Loop[/COLOR]
[COLOR="Navy"]Next[/COLOR] n
Erase vRay
Erase nRay: c = 0: tot = 0: nTot = 0: p = 0: G = 0: y = 0
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Lobsterboy1]

Hi Mick, this works. Thanks. Can you tell me how to start the results in column S rather than R, I have tried to read through the code and change it my self but I don't understand a lot of the code so cannot do it.

Thanks.

 

[MickG]

You're welcome,Glad its working.
Change Ac = 13 to Ac =14 as below:-

Num = 65: c = 0
For n = 1 To UBound(vRay, 2)
    Ac = 14: tot = 0
        Do Until vRay(1, n) = tot