Amalgamate rows onto new worksheet

TheWennerWoman · Sep 29, 2019

Hello,

I hope someone can help.

I have a sheet of data (Sheet1) which I need to manipulate using VBA. I want to keep the existing data (for sanity checking) and generate an amalgamated version on a new sheet.

The rules are quite straightforward:
(a) if an asset has a freehold status only then it stays as freehold and the values summed
(b) if an asset has a freehold and a leasehold status, both should be labelled freehold and the values summed
(c) if an asset has a leasehold status only then it stays as freehold and the values summed

The structure of the data before is

Rich (BB code):

AssetID  TenureStatus  Value

123456   Freehold      1000
123456   Leasehold     4000
123456   Leasehold     3000
123457   Leasehold     3000
123457   Leasehold     2000
123458   Freehold      2000

And what I'm looking to achieve on a new worksheet is

Rich (BB code):

AssetID  TenureStatus  Value

123456   Freehold      8000
123457   Leasehold     5000
123458   Freehold      2000

Thanks so much in advance.

alansidman · Sep 29, 2019

instead of VBA, would a Pivot Table work for you.

Data Range
[Table="class: grid"][tr][td] [/td][td]

A

[/td][td]

B

[/td][td]

C

[/td][td]

D

[/td][td]

E

[/td][td]

F

[/td][td]

G

[/td][td]

H

[/td][td]

I

[/td][/tr]
[tr][td]

1

[/td][td]

AssetID

[/td][td]

TenureStatus

[/td][td]

Value

[/td][td]

[/td][/tr]

[tr][td]

2

[/td][td]

123456

[/td][td]

Freehold

[/td][td]

1000

[/td][td]

AssetID

[/td][td]

TenureStatus

[/td][td]

Sum of Value

[/td][td]

[/td][/tr]

[tr][td]

3

[/td][td]

123456

[/td][td]

Leasehold

[/td][td]

4000

[/td][td]

123456

[/td][td]

[/td][/tr]

[tr][td]

4

[/td][td]

123456

[/td][td]

Leasehold

[/td][td]

3000

[/td][td]

Freehold

[/td][td]

1000

[/td][td]

[/td][/tr]

[tr][td]

5

[/td][td]

123457

[/td][td]

Leasehold

[/td][td]

3000

[/td][td]

Leasehold

[/td][td]

7000

[/td][td]

[/td][/tr]

[tr][td]

6

[/td][td]

123457

[/td][td]

Leasehold

[/td][td]

2000

[/td][td]

123456 Total

[/td][td]

8000

[/td][td]

[/td][/tr]

[tr][td]

7

[/td][td]

123458

[/td][td]

Freehold

[/td][td]

2000

[/td][td]

123457

[/td][td]

[/td][/tr]

[tr][td]

8

[/td][td]

Leasehold

[/td][td]

5000

[/td][td]

[/td][/tr]

[tr][td]

9

[/td][td]

123457 Total

[/td][td]

5000

[/td][td]

[/td][/tr]

[tr][td]

10

[/td][td]

123458

[/td][td]

[/td][/tr]

[tr][td]

11

[/td][td]

Freehold

[/td][td]

2000

[/td][td]

[/td][/tr]

[tr][td]

12

[/td][td]

123458 Total

[/td][td]

2000

[/td][td]

[/td][/tr]

[tr][td]

13

[/td][td]

[/td][/tr]

[tr][td]

14

[/td][td]

[/td][/tr]
[/table]

Fluff · Sep 29, 2019

How about

Code:

Sub TheWennerWoman()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Tmp As Variant
   
   Set Ws = Sheets("Sheet1")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then
            If Not .exists(Cl.Value) Then
               .Add Cl.Value, Array(Cl.Offset(, 1).Value, Cl.Offset(, 2).Value)
            Else
               Tmp = .Item(Cl.Value)
               Tmp(1) = Tmp(1) + Cl.Offset(, 2).Value
               If Cl.Offset(, 1).Value = "Freehold" Then Tmp(0) = Cl.Offset(, 1).Value
               .Item(Cl.Value) = Tmp
            End If
         End If
      Next Cl
      Sheets("Sheet2").Range("A2").Resize(.Count, 1).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 2).Value = Application.Index(.Items, 0)
   End With
End Sub

TheWennerWoman · Sep 30, 2019

Very good Fluff, that works a treat, many thanks.

Peter_SSs · Sep 30, 2019

FWIW, a variation on that approach.

Code:

Sub Amalgamate()
  Dim d As Object
  Dim c As Range
  
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
    d(c.Value) = c.Offset(, 1).Value & Split(d(c.Value) & ",", ",")(0) & "," & c.Offset(, 2).Value + Split(d(c.Value) & ",0", ",")(1)
  Next c
  With Sheets("Sheet2").Range("B1").Resize(d.Count)
    .Offset(, -1).Resize(, 2).Value = Application.Transpose(Array(d.Keys, d.Items))
    .TextToColumns DataType:=xlDelimited, Comma:=True
    .Replace What:="*Freehold*", Replacement:="Freehold", MatchCase:=False
    .Replace What:="*Leasehold*", Replacement:="Leasehold", MatchCase:=False
  End With
End Sub

Fluff · Sep 30, 2019

TheWennerWoman said:
Very good Fluff, that works a treat, many thanks.

You're welcome & thanks for the feedback

TheWennerWoman · Oct 6, 2019

Can either of these two (quite excellent) approaches be adapted slightly? I have tried but I actually am not sure how either piece of code is working

So in my original example, I had a value in column C. If there was also a value in column G, I'd need that added in to the overall value. Same rules as before. So:

Rich (BB code):

Asset ID    Tenure Status    Value    Blah1    Blah2    Blah3    Another Value
123456      Freehold         1000       a       b         c          2000
123456      Leasehold        4000       d       e         f          8000
123456      Leasehold        3000       g       h         i          6000
123457      Leasehold        3000       j       k         l          6000
123457      Leasehold        2000       m       n         o          4000
123458      Freehold         2000       p       q         r          4000

And the desired outcome:

Rich (BB code):

AssetID  TenureStatus  Value

123456   Freehold      24000
123457   Leasehold     15000
123458   Freehold       6000

Thanks again for your time. If the moderators would rather I start a new thread, please let me know

Peter_SSs · Oct 6, 2019

No, it's a continuation of this thread so we continue here.
Try

Rich (BB code):

<del>d(c.Value) = c.Offset(, 1).Value & Split(d(c.Value) & ",", ",")(0) & "," & c.Offset(, 2).Value + Split(d(c.Value) & ",0", ",")(1)</del>
d(c.Value) = c.Offset(, 1).Value & Split(d(c.Value) & ",", ",")(0) & "," & c.Offset(, 2).Value + c.Offset(, 6).Value + Split(d(c.Value) & ",0", ",")(1)

Fluff · Oct 6, 2019

Or, with my code

Rich (BB code):

Sub TheWennerWoman()
   Dim Cl As Range
   Dim ws As Worksheet
   Dim Tmp As Variant
   
   Set ws = Sheets("Sheet1")
   With CreateObject("scripting.dictionary")
      For Each Cl In ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then
            If Not .Exists(Cl.Value) Then
               .Add Cl.Value, Array(Cl.Offset(, 1).Value, Cl.Offset(, 2).Value + Cl.Offset(, 6).Value)
            Else
               Tmp = .Item(Cl.Value)
               Tmp(1) = Tmp(1) + Cl.Offset(, 2).Value + Cl.Offset(, 6).Value
               If Cl.Offset(, 1).Value = "Freehold" Then Tmp(0) = Cl.Offset(, 1).Value
               .Item(Cl.Value) = Tmp
            End If
         End If
      Next Cl
      Sheets("Sheet2").Range("A2").Resize(.Count, 1).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 2).Value = Application.Index(.Items, 0)
   End With
End Sub

TheWennerWoman · Oct 6, 2019

Thank you both for your time (and patience); I can only hope that one day I can contribute to this forum with answers rather than just questions!

Amalgamate rows onto new worksheet

TheWennerWoman

Active Member

Excel Facts

alansidman

Well-known Member

Fluff

MrExcel MVP, Moderator

TheWennerWoman

Active Member

Peter_SSs

MrExcel MVP, Moderator

Fluff

MrExcel MVP, Moderator

TheWennerWoman

Active Member

Peter_SSs

MrExcel MVP, Moderator

Fluff

MrExcel MVP, Moderator

TheWennerWoman

Active Member

Similar threads

Forum statistics

Share this page

Amalgamate rows onto new worksheet

Active Member

Excel Facts

Well-known Member

MrExcel MVP, Moderator

Active Member

MrExcel MVP, Moderator

MrExcel MVP, Moderator

Active Member

MrExcel MVP, Moderator

MrExcel MVP, Moderator

Active 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