to array or not? (summing up same category in range)

airforceone · Aug 31, 2022

It's been 2 weeks now since I started a mini project but my clogged brain won't cooperate with me

I hate to burden but can anyone help me, given the sample data I would like to merge all Med Category and its corresponding grams and value (number of Med per Unique Numbers Varies)
I hope I explained it clearly

Online File.xlsx

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

1

UNIQUE NUMBER

UNDER

DATE

CLASS

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

2

A0001

PHA 1

2016.01.20

OTC

VIT - A

1

5

3

A0002

PHA 2

2016.03.18

NON-TAKERS

VIT - B

1

5

VIT - E

3

15

4

A0003

PHA 3

2016.04.19

OTC

VIT - C

2

10

VIT - C

4

20

VIT - C

1

5

A0004

PHA 4

2016.04.22

SIGNED

VIT - D

3

15

VIT - D

5

25

VIT - D

1

5

VIT - C

1

5

6

A0005

PHA 5

2016.05.25

NON-TAKERS

VIT - D

4

20

VIT - E

6

30

VIT - E

2

10

7

A0006

PHA 6

2016.06.23

OTC

VIT - E

5

25

8

9

10

EXPECTED OUTPUT

11

UNIQUE NUMBER

UNDER

DATE

CLASS

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

12

A0001

PHA 1

2016.01.20

OTC

VIT - A

1

5

13

A0002

PHA 2

2016.03.18

NON-TAKERS

VIT - B

1

5

VIT - E

3

15

14

A0003

PHA 3

2016.04.19

OTC

VIT - C

7

35

15

A0004

PHA 4

2016.04.22

SIGNED

VIT - D

9

45

VIT - C

1

5

16

A0005

PHA 5

2016.05.25

NON-TAKERS

VIT - D

4

20

VIT - E

8

40

17

A0006

PHA 6

2016.06.23

OTC

VIT - E

5

25

VITs

bebo021999 · Sep 4, 2022

Try:

VBA Code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr()
Dim dic As Object, key
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "D").End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
rng = Range("E2", Cells(lr, lc)).Value
For i = 1 To UBound(rng)
    Set dic = CreateObject("Scripting.dictionary")
    ReDim arr(1 To 1, 1 To lc - 4)
    k = 0
    For j = 1 To UBound(rng, 2) Step 3
        If Not dic.exists(rng(i, j)) And rng(i, j) <> "" Then
            dic.Add rng(i, j), rng(i, j + 1) & "|" & rng(i, j + 2)
        Else
            dic(rng(i, 1)) = (Split(dic(rng(i, 1)), "|")(0) + rng(i, j + 1)) & "|" & (Split(dic(rng(i, 1)), "|")(1) + rng(i, j + 2))
        End If
    Next
    For Each key In dic.keys
        k = k + 1: arr(1, k) = key
        k = k + 1: arr(1, k) = Split(dic(key), "|")(0)
        k = k + 1: arr(1, k) = Split(dic(key), "|")(1)
    Next
    Range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
    Cells(i + 1, 5).Resize(1, k).Value = arr
    Set dic = Nothing
Next
Application.ScreenUpdating = True
End Sub

airforceone · Sep 5, 2022

bebo021999 said:

Try:

VBA Code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr()
Dim dic As Object, key
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "D").End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
rng = Range("E2", Cells(lr, lc)).Value
For i = 1 To UBound(rng)
    Set dic = CreateObject("Scripting.dictionary")
    ReDim arr(1 To 1, 1 To lc - 4)
    k = 0
    For j = 1 To UBound(rng, 2) Step 3
        If Not dic.exists(rng(i, j)) And rng(i, j) <> "" Then
            dic.Add rng(i, j), rng(i, j + 1) & "|" & rng(i, j + 2)
        Else
            dic(rng(i, 1)) = (Split(dic(rng(i, 1)), "|")(0) + rng(i, j + 1)) & "|" & (Split(dic(rng(i, 1)), "|")(1) + rng(i, j + 2))
        End If
    Next
    For Each key In dic.keys
        k = k + 1: arr(1, k) = key
        k = k + 1: arr(1, k) = Split(dic(key), "|")(0)
        k = k + 1: arr(1, k) = Split(dic(key), "|")(1)
    Next
    Range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
    Cells(i + 1, 5).Resize(1, k).Value = arr
    Set dic = Nothing
Next
Application.ScreenUpdating = True
End Sub

running with the following data sample

Online File.xlsx

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

1

UNIQUE NUMBER

UNDER

DATE

CLASS

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

2

A0001

PHA 1

2016.01.20

OTC

VIT - A

1

5

3

A0002

PHA 2

2016.03.18

NON-TAKERS

VIT - B

1

5

VIT - E

3

15

4

A0003

PHA 3

2016.04.19

OTC

VIT - C

2

10

VIT - C

4

20

VIT - C

1

5

VIT - C

1

5

VIT - C

1

5

A0004

PHA 4

2016.04.22

SIGNED

VIT - D

3

15

VIT - D

5

25

VIT - D

1

5

VIT - C

1

5

VIT - D

1

5

VIT - C

1

5

6

A0005

PHA 5

2016.05.25

NON-TAKERS

VIT - D

4

20

VIT - E

6

30

VIT - E

2

10

VIT - C

1

5

VIT - E

2

10

VITs (19)

Row 5 & 6 computations seems a bit off, would you care mate running with the above data ....

bebo021999 · Sep 5, 2022

This is how it looks after code running

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

1

UNIQUE NUMBER

UNDER

DATE

CLASS

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

2

A0001

PHA 1

20/01/2016

OTC

VIT - A

1

5

3

A0002

PHA 2

18/03/2016

NON-TAKERS

VIT - B

1

5

VIT - E

3

15

4

A0003

PHA 3

19/04/2016

OTC

VIT - C

9

45

5

A0004

PHA 4

22/04/2016

SIGNED

VIT - D

11

55

VIT - C

1

5

6

A0005

PHA 5

25/05/2016

NON-TAKERS

VIT - D

8

40

VIT - E

6

30

VIT - C

1

5

Sheet1

airforceone · Sep 5, 2022

bebo021999 said:
This is how it looks after code running

Book1
A B C D E F G H I J K L M N O P Q R S T U V
1 UNIQUE NUMBER UNDER DATE CLASS MED Grams Value MED Grams Value MED Grams Value MED Grams Value MED Grams Value MED Grams Value
2 A0001 PHA 1 20/01/2016 OTC VIT - A 1 5
3 A0002 PHA 2 18/03/2016 NON-TAKERS VIT - B 1 5 VIT - E 3 15
4 A0003 PHA 3 19/04/2016 OTC VIT - C 9 45
5 A0004 PHA 4 22/04/2016 SIGNED VIT - D 11 55 VIT - C 1 5
6 A0005 PHA 5 25/05/2016 NON-TAKERS VIT - D 8 40 VIT - E 6 30 VIT - C 1 5
Sheet1

Output after Processed (EXPECTED RESULT)

Online File.xlsx

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

17

UNIQUE NUMBER

UNDER

DATE

CLASS

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

MED

Grams

Value

18

A0001

PHA 1

42389

OTC

VIT - A

1

5

19

A0002

PHA 2

42447

NON-TAKERS

VIT - B

1

5

VIT - E

3

15

20

A0003

PHA 3

42479

OTC

VIT - C

9

45

21

A0004

PHA 4

42482

SIGNED

VIT - D

10

50

VIT - C

2

10

22

A0005

PHA 5

42515

NON-TAKERS

VIT - D

4

20

VIT - E

10

50

VIT - C

1

5

Sheet18

bebo021999 · Sep 5, 2022

Try again:

VBA Code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr()
Dim dic As Object, key
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "D").End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
rng = Range("E2", Cells(lr, lc)).Value
For i = 1 To UBound(rng)
    Set dic = CreateObject("Scripting.dictionary")
    ReDim arr(1 To 1, 1 To lc - 4)
    k = 0
    For j = 1 To UBound(rng, 2) Step 3
    If rng(i, j) <> "" Then
        If Not dic.exists(rng(i, j)) Then
            dic.Add rng(i, j), rng(i, j + 1) & "|" & rng(i, j + 2)
        Else
            dic(rng(i, j)) = Split(dic(rng(i, j)), "|")(0) + rng(i, j + 1) & "|" & Split(dic(rng(i, j)), "|")(1) + rng(i, j + 2)
        End If
    End If
    Next
    For Each key In dic.keys
        k = k + 1: arr(1, k) = key
        k = k + 1: arr(1, k) = Split(dic(key), "|")(0)
        k = k + 1: arr(1, k) = Split(dic(key), "|")(1)
    Next
    Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items
    Range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
    Cells(i + 1, 5).Resize(1, k).Value = arr
    dic.RemoveAll
Next
Application.ScreenUpdating = True
End Sub

airforceone · Sep 5, 2022

bebo021999 said:

Try again:

VBA Code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr()
Dim dic As Object, key
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "D").End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
rng = Range("E2", Cells(lr, lc)).Value
For i = 1 To UBound(rng)
    Set dic = CreateObject("Scripting.dictionary")
    ReDim arr(1 To 1, 1 To lc - 4)
    k = 0
    For j = 1 To UBound(rng, 2) Step 3
    If rng(i, j) <> "" Then
        If Not dic.exists(rng(i, j)) Then
            dic.Add rng(i, j), rng(i, j + 1) & "|" & rng(i, j + 2)
        Else
            dic(rng(i, j)) = Split(dic(rng(i, j)), "|")(0) + rng(i, j + 1) & "|" & Split(dic(rng(i, j)), "|")(1) + rng(i, j + 2)
        End If
    End If
    Next
    For Each key In dic.keys
        k = k + 1: arr(1, k) = key
        k = k + 1: arr(1, k) = Split(dic(key), "|")(0)
        k = k + 1: arr(1, k) = Split(dic(key), "|")(1)
    Next
    Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items
    Range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
    Cells(i + 1, 5).Resize(1, k).Value = arr
    dic.RemoveAll
Next
Application.ScreenUpdating = True
End Sub

my question is can you explain the following code: (what is the constant value for and where did you get it?)
because appending your code to my Main code generates RT 1004 error but using it as stand-alone works a beauty and does not generates such error

VBA Code:

ReDim arr(1 To 1, 1 To lc - 4)

Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items
range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
Cells(i + 1, 5).Resize(1, k).Value = arr

bebo021999 · Sep 5, 2022

airforceone said:
my question is can you explain the following code: (what is the constant value for and where did you get it?)
because appending your code to my Main code generates RT 1004 error but using it as stand-alone works a beauty and does not generates such error

VBA Code:

ReDim arr(1 To 1, 1 To lc - 4) Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents Cells(i + 1, 5).Resize(1, k).Value = arr

Sorry, I forgot to remove this line. Its just for testing during coding.

VBA Code:

Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items

Then, should be:

VBA Code:

ReDim arr(1 To 1, 1 To lc - 4) ' the output array. lc = Last column index. lc-4 = columns count from column E to the right
range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents ' clear the old values from column E to the right
Cells(i + 1, 5).Resize(1, k).Value = arr' paste value from arr to column E to the right

airforceone · Sep 5, 2022

bebo021999 said:

Sorry, I forgot to remove this line. Its just for testing during coding.

VBA Code:

Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items

Then, should be:

VBA Code:

ReDim arr(1 To 1, 1 To lc - 4) ' the output array. lc = Last column index. lc-4 = columns count from column E to the right
range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents ' clear the old values from column E to the right
Cells(i + 1, 5).Resize(1, k).Value = arr' paste value from arr to column E to the right

OTWH, will clear my head and tackle my RT error tomorrow! i hope you could still lend a hand thanks mate....

airforceone · Sep 7, 2022

bebo021999 said:

Sorry, I forgot to remove this line. Its just for testing during coding.

VBA Code:

Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items

Then, should be:

VBA Code:

ReDim arr(1 To 1, 1 To lc - 4) ' the output array. lc = Last column index. lc-4 = columns count from column E to the right
range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents ' clear the old values from column E to the right
Cells(i + 1, 5).Resize(1, k).Value = arr' paste value from arr to column E to the right

finally!
after a couple of days staring at my code the target data, I managed to pinpoint the culprit!
the code works smoothly but when it encounter a null/empty value in its range it somehow breaks the code and generates error!
what I did was before running the code I deleted (via VBA) all null/empty cell since it wont be needed anyway!
lo and behold the power of community helping each other thanks mate really appreciate it!
I always try to solved my code problem before asking for help and always every time people really helped! thanks again...

bebo021999 · Sep 7, 2022

Cheer!
BTW, could you share your latest data with null cells, and final code?

to array or not? (summing up same category in range)

airforceone

Board Regular

bebo021999

Well-known Member

Excel Facts

airforceone

Board Regular

bebo021999

Well-known Member

airforceone

Board Regular

bebo021999

Well-known Member

airforceone

Board Regular

bebo021999

Well-known Member

airforceone

Board Regular

airforceone

Board Regular

bebo021999

Well-known Member

Similar threads

Forum statistics

Share this page

to array or not? (summing up same category in range)

Board Regular

Well-known Member

Excel Facts

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock