Amalgamate rows onto new worksheet

T

TheWennerWoman

Active Member
Joined
Aug 1, 2019
Messages
303
Office Version
  1. 365
Platform
  1. Windows
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.
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
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][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
2​
[/td][td]
123456​
[/td][td]
Freehold​
[/td][td]
1000​
[/td][td]
​
[/td][td]
AssetID​
[/td][td]
TenureStatus​
[/td][td]
Sum of Value​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
3​
[/td][td]
123456​
[/td][td]
Leasehold​
[/td][td]
4000​
[/td][td]
​
[/td][td]
123456​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
4​
[/td][td]
123456​
[/td][td]
Leasehold​
[/td][td]
3000​
[/td][td]
​
[/td][td]
​
[/td][td]
Freehold​
[/td][td]
1000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
5​
[/td][td]
123457​
[/td][td]
Leasehold​
[/td][td]
3000​
[/td][td]
​
[/td][td]
​
[/td][td]
Leasehold​
[/td][td]
7000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
6​
[/td][td]
123457​
[/td][td]
Leasehold​
[/td][td]
2000​
[/td][td]
​
[/td][td]
123456 Total​
[/td][td]
​
[/td][td]
8000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
7​
[/td][td]
123458​
[/td][td]
Freehold​
[/td][td]
2000​
[/td][td]
​
[/td][td]
123457​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
8​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
Leasehold​
[/td][td]
5000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
9​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
123457 Total​
[/td][td]
​
[/td][td]
5000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
10​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
123458​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
11​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
Freehold​
[/td][td]
2000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
12​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
123458 Total​
[/td][td]
​
[/td][td]
2000​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
13​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]


[tr][td]
14​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][/tr]
[/table]
 
Upvote 0
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
 
Upvote 0
Solution
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
 
Last edited:
Upvote 0
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 :)
 
Upvote 0
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)
 
Last edited:
Upvote 0
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
 
Upvote 0
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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
move and delete rows contains minus and positive value from range to another
Replies
8
Views
101
Mussa
M
L
  • Question Question
VBA Code to add in blank rows at a specific point, then do a formula in that blank row
Replies
1
Views
825
Peter_SSs
Peter_SSs
A
  • Question Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
538
AlfredDB
A
O
  • Question Question
sum or subtract for the same cell based on match DATE
Replies
0
Views
328
Omran Y
O
S
  • Question Question
Create New Sheet with Specific Name Based on Variable Cell
Replies
0
Views
242
SBExcel123
S

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

Share this page

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