Amalgamate rows onto new worksheet

[TheWennerWoman]

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

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

AssetID  TenureStatus  Value

123456   Freehold      8000
123457   Leasehold     5000
123458   Freehold      2000

Thanks so much in advance.

 

[alansidman]

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

Data Range

	A​	B​	C​	D​	E​	F​	G​	H​	I​
1​	AssetID​	TenureStatus​	Value​	​	​	​	​	​	​
2​	123456​	Freehold​	1000​	​	AssetID​	TenureStatus​	Sum of Value​	​	​
3​	123456​	Leasehold​	4000​	​	123456​	​	​	​	​
4​	123456​	Leasehold​	3000​	​	​	Freehold​	1000​	​	​
5​	123457​	Leasehold​	3000​	​	​	Leasehold​	7000​	​	​
6​	123457​	Leasehold​	2000​	​	123456 Total​	​	8000​	​	​
7​	123458​	Freehold​	2000​	​	123457​	​	​	​	​
8​	​	​	​	​	​	Leasehold​	5000​	​	​
9​	​	​	​	​	123457 Total​	​	5000​	​	​
10​	​	​	​	​	123458​	​	​	​	​
11​	​	​	​	​	​	Freehold​	2000​	​	​
12​	​	​	​	​	123458 Total​	​	2000​	​	​
13​	​	​	​	​	​	​	​	​	​
14​	​	​	​	​	​	​	​	​	​

 

[Fluff]

How about

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]

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

 

[Peter_SSs]

FWIW, a variation on that approach.

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]

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

You're welcome & thanks for the feedback

 

[TheWennerWoman]

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:

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:

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]

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

<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]

Or, with my 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]

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!