Extract data based on a criteria

B

Bobstar

New Member
Joined
Oct 7, 2020
Messages
24
Office Version
  1. 2019
Platform
  1. Windows
Hi all

There are several VBA solutions on copying data but couldn’t find one that addresses my issue.

I have a workbook with two sheets. Sheet one is a summary table with three columns (shown below) whilst sheet two holds the main data.
I would like VBA to copy data from sheet two using ‘category’ as the criteria and paste to sheet one in the third column. As illustrated below, the number of rows will differ dependent on the ‘category’.

The end result will look as the table below. I hope the above makes sense.

Thanks in advance

RowsCategoryUnderlying items (data to be copied)
0Cat 1Asset 1
0Cat 2Asset 2
3Cat 3Asset 1
Asset 2
Asset 3
0Cat 4Asset 4
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
You've finally shown just one table so no input-output relationship can be defined :(
 
Upvote 0
Kaper said:
You've finally shown just one table so no input-output relationship can be defined :(
Click to expand...
Thanks for replying. The original table is the output extracted from a large data source. The columns of interest are shown below. So relationship between the input-output is the category column and I would like to copy across the asset name range.

CategoryAsset name
Category 1Asset 1
Category 2Asset 2
Category 3Asset 1
Category 3Asset 2
Category 3Asset 3
Category 4Asset 4
Category 5Asset 5
Category 5Asset 6
Category 5Asset 7
Category 6Asset 8
Category 6Asset 9
Category 6Asset 10
Category 7Asset 11
Category 7Asset 12
Category 7Asset 13
Category 8Asset 14
Category 9Asset 15
Category 9Asset 4
Category 9Asset 6
Category 10Asset 8
 
Upvote 0
Well, for me it is still not clear what you have,, and what you want to achieve. Just empty cells if category name repeats with different assets? (Leaving Category name only at first asset of given category?) And what is rows? if there were 1 1 3 1 or 0 0 2 0 in the first example tabe, I'd understand it, but 0 0 3 0 ...?

So anyone is welcome to join the thread.
 
Upvote 0
Kaper said:
Well, for me it is still not clear what you have,, and what you want to achieve. Just empty cells if category name repeats with different assets? (Leaving Category name only at first asset of given category?) And what is rows? if there were 1 1 3 1 or 0 0 2 0 in the first example tabe, I'd understand it, but 0 0 3 0 ...?

So anyone is welcome to join the thread.
Click to expand...
I’ve noted your comments and if it’s not clear to you then it’s very likely it won’t be to others. It’s one of those things that’s easier to talk through but I’ll give it another try.
I have two data sets as follows:
  • Data 1 – shows name, the asset they hold and allocation. If they hold a “model”, the corresponding Asset name has underlying assets. So, for example, client “C” in the table below holds HSBC Islamic Equity which has 5 underlying assets.
  • Data 2 – A list of all models and their underlying assets and allocations.
I would like a macro that does the following:
  • Wherever the ISIN code is a model, add extra rows to cater for the underlying assets. In my previous table I had created a helper column to determine the number of rows to be added.
  • Fill in the blanks with data (see below)
  • Show breakdown of the models. If Model is the ISIN code, then the macro will refer to Data 2 for list of the underlying assets and allocations and copy across.
I have a macro that does 1 and 2 (shown below) but I’m struggling with 3.

VBA Code: 
Sub insert_rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    With Cells(r, 9)
        If IsNumeric(.Value) And (.Value) <> 0 Then
        Rows(r + 1).Resize(.Value).Insert
    End If
    End With
Next r
Call fill_from_above
Application.ScreenUpdating = True
End Sub

Sub fill_from_above()
    With Range("A4:M" & Range("M" & Rows.Count).End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
    End With
End Sub


The output should be as per the photo attached
 

Attachments

  • Picture1.png
    Picture1.png
    71.2 KB · Views: 126
Last edited by a moderator:
Upvote 0
This is a bit long but give it a try on a copy of your workbook. It will overwrite your Data1 sheet
I have assumed you don't need to actually "insert rows" ie that you don't have additional columns and formulas on the rows.
You will need to change the Sheet names if you haven't called them Data1 and Data2

VBA Code: 
Sub InsertModelBreakdown()

    Dim shtData1 As Worksheet, shtData2 As Worksheet
    Dim rngData1 As Range, rngData2 As Range
    Dim arrData1 As Variant, arrData2 As Variant, arrOut As Variant
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long
    Dim iOutMax As Long, iOut As Long
    Dim dictData2 As Object, dictKey As String
    Dim coll As Collection
    
    Set shtData1 = Worksheets("Data1")                                                          ' <-- Change to your sheet name
    With shtData1
        lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData1 = .Range("A2", .Cells(lastRow1, "D"))
        arrData1 = rngData1.Value
    End With
     
    Set shtData2 = Worksheets("Data2")                                                          ' <-- Change to your sheet name
    With shtData2
        lastRow2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData2 = .Range("A2", .Cells(lastRow2, "C"))
        arrData2 = rngData2.Value
    End With

    Set dictData2 = CreateObject("Scripting.dictionary")
    dictData2.CompareMode = vbTextCompare
    
    ' Load model data into Dictionary
    For i = 1 To UBound(arrData2)
        dictKey = arrData2(i, 1)
        If Not dictData2.exists(dictKey) Then
            Set coll = New Collection
            coll.Add i
            dictData2.Add dictKey, coll
        Else
            dictData2(dictKey).Add i
        End If
    Next i

    ' Count maximumn lines in output
    iOutMax = UBound(arrData1)
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If dictData2.exists(dictKey) Then
            iOutMax = iOutMax + dictData2(dictKey).Count - 1
        End If
    Next i
    
    ReDim arrOut(1 To iOutMax, 1 To UBound(arrData1, 2) + 1)
    
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If UCase(arrData1(i, 2)) = "MODEL" And dictData2.exists(dictKey) Then
            For k = 1 To dictData2(dictKey).Count
                iOut = iOut + 1
                For j = 1 To UBound(arrData1, 2) - 1
                    arrOut(iOut, j) = arrData1(i, j)
                Next j
                arrOut(iOut, UBound(arrOut, 2) - 1) = arrData2(dictData2(dictKey).Item(k), 2)   ' Breakdown
                arrOut(iOut, UBound(arrOut, 2)) = arrData2(dictData2(dictKey).Item(k), 3)       ' Allocation
            Next k
        Else
            iOut = iOut + 1
            For j = 1 To UBound(arrData1, 2) - 1
                arrOut(iOut, j) = arrData1(i, j)
            Next j
            arrOut(iOut, UBound(arrOut, 2) - 1) = arrData1(i, 3)                                ' Breakdown (Repeat Asset)
            arrOut(iOut, UBound(arrOut, 2)) = arrData1(i, UBound(arrData1, 2))                  ' Allocation
        End If
    
    Next i
    
    shtData1.Columns(UBound(arrData1, 2)).Insert
    shtData1.Cells(1, UBound(arrData1, 2)).Value = "Breakdown"
    rngData1.Resize(iOut, UBound(arrOut, 2)).Value = arrOut
    
    With shtData1.Columns(UBound(arrOut, 2))
        .NumberFormat = .Cells(2).NumberFormat
    End With

End Sub
 
Upvote 0
Solution
In case anyone else wants to have a go here is my test data.

20240925 VBA Split Out Model Allocation Bobstar.xlsm
ABCD
1NameISIN CodeAsset NameAllocation
2ACashCash100%
3BNoISINFixed Interest100%
4CIE008Fidelity100%
5DModelHSBC100%
6ECashCash100%
7FModelBMAM100%
Data1


20240925 VBA Split Out Model Allocation Bobstar.xlsm
ABC
1Asset NameBreakdownAllocation
2HSBCEurope20%
3HSBCFTSE20%
4HSBCUK Bond20%
5HSBCJP20%
6HSBCPacific20%
7BMAMReturns10%
8BMAMStrat60%
9BMAMUK30%
Data2
 
Upvote 0
Alex Blakenburg said:
This is a bit long but give it a try on a copy of your workbook. It will overwrite your Data1 sheet
I have assumed you don't need to actually "insert rows" ie that you don't have additional columns and formulas on the rows.
You will need to change the Sheet names if you haven't called them Data1 and Data2

VBA Code: 
Sub InsertModelBreakdown()

    Dim shtData1 As Worksheet, shtData2 As Worksheet
    Dim rngData1 As Range, rngData2 As Range
    Dim arrData1 As Variant, arrData2 As Variant, arrOut As Variant
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long
    Dim iOutMax As Long, iOut As Long
    Dim dictData2 As Object, dictKey As String
    Dim coll As Collection
  
    Set shtData1 = Worksheets("Data1")                                                          ' <-- Change to your sheet name
    With shtData1
        lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData1 = .Range("A2", .Cells(lastRow1, "D"))
        arrData1 = rngData1.Value
    End With
   
    Set shtData2 = Worksheets("Data2")                                                          ' <-- Change to your sheet name
    With shtData2
        lastRow2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData2 = .Range("A2", .Cells(lastRow2, "C"))
        arrData2 = rngData2.Value
    End With

    Set dictData2 = CreateObject("Scripting.dictionary")
    dictData2.CompareMode = vbTextCompare
  
    ' Load model data into Dictionary
    For i = 1 To UBound(arrData2)
        dictKey = arrData2(i, 1)
        If Not dictData2.exists(dictKey) Then
            Set coll = New Collection
            coll.Add i
            dictData2.Add dictKey, coll
        Else
            dictData2(dictKey).Add i
        End If
    Next i

    ' Count maximumn lines in output
    iOutMax = UBound(arrData1)
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If dictData2.exists(dictKey) Then
            iOutMax = iOutMax + dictData2(dictKey).Count - 1
        End If
    Next i
  
    ReDim arrOut(1 To iOutMax, 1 To UBound(arrData1, 2) + 1)
  
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If UCase(arrData1(i, 2)) = "MODEL" And dictData2.exists(dictKey) Then
            For k = 1 To dictData2(dictKey).Count
                iOut = iOut + 1
                For j = 1 To UBound(arrData1, 2) - 1
                    arrOut(iOut, j) = arrData1(i, j)
                Next j
                arrOut(iOut, UBound(arrOut, 2) - 1) = arrData2(dictData2(dictKey).Item(k), 2)   ' Breakdown
                arrOut(iOut, UBound(arrOut, 2)) = arrData2(dictData2(dictKey).Item(k), 3)       ' Allocation
            Next k
        Else
            iOut = iOut + 1
            For j = 1 To UBound(arrData1, 2) - 1
                arrOut(iOut, j) = arrData1(i, j)
            Next j
            arrOut(iOut, UBound(arrOut, 2) - 1) = arrData1(i, 3)                                ' Breakdown (Repeat Asset)
            arrOut(iOut, UBound(arrOut, 2)) = arrData1(i, UBound(arrData1, 2))                  ' Allocation
        End If
  
    Next i
  
    shtData1.Columns(UBound(arrData1, 2)).Insert
    shtData1.Cells(1, UBound(arrData1, 2)).Value = "Breakdown"
    rngData1.Resize(iOut, UBound(arrOut, 2)).Value = arrOut
  
    With shtData1.Columns(UBound(arrOut, 2))
        .NumberFormat = .Cells(2).NumberFormat
    End With

End Sub
Click to expand...

Alex Blakenburg said:
This is a bit long but give it a try on a copy of your workbook. It will overwrite your Data1 sheet
I have assumed you don't need to actually "insert rows" ie that you don't have additional columns and formulas on the rows.
You will need to change the Sheet names if you haven't called them Data1 and Data2

VBA Code: 
Sub InsertModelBreakdown()

    Dim shtData1 As Worksheet, shtData2 As Worksheet
    Dim rngData1 As Range, rngData2 As Range
    Dim arrData1 As Variant, arrData2 As Variant, arrOut As Variant
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long
    Dim iOutMax As Long, iOut As Long
    Dim dictData2 As Object, dictKey As String
    Dim coll As Collection
   
    Set shtData1 = Worksheets("Data1")                                                          ' <-- Change to your sheet name
    With shtData1
        lastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData1 = .Range("A2", .Cells(lastRow1, "D"))
        arrData1 = rngData1.Value
    End With
    
    Set shtData2 = Worksheets("Data2")                                                          ' <-- Change to your sheet name
    With shtData2
        lastRow2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData2 = .Range("A2", .Cells(lastRow2, "C"))
        arrData2 = rngData2.Value
    End With

    Set dictData2 = CreateObject("Scripting.dictionary")
    dictData2.CompareMode = vbTextCompare
   
    ' Load model data into Dictionary
    For i = 1 To UBound(arrData2)
        dictKey = arrData2(i, 1)
        If Not dictData2.exists(dictKey) Then
            Set coll = New Collection
            coll.Add i
            dictData2.Add dictKey, coll
        Else
            dictData2(dictKey).Add i
        End If
    Next i

    ' Count maximumn lines in output
    iOutMax = UBound(arrData1)
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If dictData2.exists(dictKey) Then
            iOutMax = iOutMax + dictData2(dictKey).Count - 1
        End If
    Next i
   
    ReDim arrOut(1 To iOutMax, 1 To UBound(arrData1, 2) + 1)
   
    For i = 1 To UBound(arrData1)
        dictKey = arrData1(i, 3)
        If UCase(arrData1(i, 2)) = "MODEL" And dictData2.exists(dictKey) Then
            For k = 1 To dictData2(dictKey).Count
                iOut = iOut + 1
                For j = 1 To UBound(arrData1, 2) - 1
                    arrOut(iOut, j) = arrData1(i, j)
                Next j
                arrOut(iOut, UBound(arrOut, 2) - 1) = arrData2(dictData2(dictKey).Item(k), 2)   ' Breakdown
                arrOut(iOut, UBound(arrOut, 2)) = arrData2(dictData2(dictKey).Item(k), 3)       ' Allocation
            Next k
        Else
            iOut = iOut + 1
            For j = 1 To UBound(arrData1, 2) - 1
                arrOut(iOut, j) = arrData1(i, j)
            Next j
            arrOut(iOut, UBound(arrOut, 2) - 1) = arrData1(i, 3)                                ' Breakdown (Repeat Asset)
            arrOut(iOut, UBound(arrOut, 2)) = arrData1(i, UBound(arrData1, 2))                  ' Allocation
        End If
   
    Next i
   
    shtData1.Columns(UBound(arrData1, 2)).Insert
    shtData1.Cells(1, UBound(arrData1, 2)).Value = "Breakdown"
    rngData1.Resize(iOut, UBound(arrOut, 2)).Value = arrOut
   
    With shtData1.Columns(UBound(arrOut, 2))
        .NumberFormat = .Cells(2).NumberFormat
    End With

End Sub
Click to expand...
Thank Alex. The code works perfectly well. Much appreciated
 
Upvote 0
@Alex Blakenburg - you are too kind, I was just trying to understand what is real requirement :).
OK, may be I hepled a bit by pushing @Bobstar to give enough details, so YOU could hepl him.
But the work was yours!
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Smarter alternative to Name Manager & Indirect Formula?
Replies
1
Views
215
RoryA
RoryA
A
  • Question
Excel - looking up data with multiple criteria from table/array, date must be same or nearest before the target cell
Replies
8
Views
395
Peter_SSs
Peter_SSs
R
  • Solved
How do I extract the data label of a trendline in VBA?
2
Replies
14
Views
2K
RockandGrohl
R
D
  • Question
Issue with EntireRow.Delete
2
Replies
11
Views
1K
RoryA
RoryA
F
  • Question
Filter Formula W/ 3 Criteria (Leaving Blank will populate all)
Replies
2
Views
353
FiggyDad
F

Forum statistics

Threads
1,221,854
Messages
6,162,450
Members
451,765
Latest member
craigvan888

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