Creating a Dynamic List from Two Worksheets

G

GuyGadois

Active Member
Joined
Jan 12, 2009
Messages
342
Office Version
  1. 2019
Platform
  1. Windows
This is beyond my excel skills. I tried doing this in a pivot table but couldn't get it to work.

Overall, I have a couple of investment portfolios that are made of various sub portfolios that hold portfolios of securities. I frequently change the percentages and want an easy way to figure out the final allocation.

This is the first worksheet. The first column display my three portfolios I have (Growth, Moderate and Conservative). Each of those portfolios has sub-portfolios (Tech, Healthcare, bonds and conservative).

Investments
HIJ
2Portfolio NameSub Model NameWeight
3GrowthTech67%
4GrowthHealthcare10%
5GrowthBonds10%
6GrowthConservative13%
7ModerateTech43%
8ModerateHealthcare8%
9ModerateBonds32%
10ModerateConservative17%
11ConservativeTech43%
12ConservativeHealthcare8%
13ConservativeBonds32%
14ConservativeConservative17%
Sheet 1


The second Worksheet has a table that displays the securities in each of the Sub Models. From this information, I want to be able to have a third worksheet that can display all the end portfolios.

Investments
HIJ
16Sub Model NameSymbolSymbol Weight
17TechAAPL25.00%
18TechFB25.00%
19TechAMZN25.00%
20TechNFLX25.00%
21HealthcarePFE33.00%
22HealthcareLLY33.00%
23HealthcareXLH34.00%
24BondsAGG100.00%
25ConservativeJPST50.00%
26ConservativeTIPS50.00%
Sheet 2


The yellow cells are picklists (data validations of the Allocation Model Names) and when you pick it will list out all the securities and their weight. Weight is the Sub-model weight for each of the securities in that sub-model. The formulas I put in here are irrelevant and just for showing how I want the end information to appear.

Any help would be appreciated. I have worked for some time on this and just can't figure out how to tackle this

Cheers,

GG

Investments
LMNOP
2GrowthWeightModerateWeight
3AAPL16.8%AAPL10.8%
4FB16.8%FB10.8%
5AMZN16.8%AMZN10.8%
6NFLX16.8%NFLX10.8%
7PFE3.300%PFE2.640%
8LLY3.300%LLY2.640%
9XLH3.400%XLH2.720%
10AGG10%AGG32%
11JPST6.500%JPST8.500%
12TIPS6.500%TIPS8.500%
13100.0%100.0%
Sheet 3
Cell Formulas
RangeFormula
L3:L12L3=I17
O3:O12O3=I17
M3M3=Table4[@Weight]*J17
M4M4=J3*J18
M5M5=J3*J19
M6:M7M6=J3*J20
M8M8=J4*J22
M9,M11M9=J23*J4
M10M10=J5
M12M12=J26*J6
M13,P13M13=SUM(M3:M12)
P3P3=J7*J17
P4P4=J7*J18
P5P5=J7*J19
P6:P7P6=J7*J20
P8P8=J8*J22
P9:P10P9=J8*J23
P11P11=J25*J10
P12P12=J26*J10
Cells with Data Validation
CellAllowCriteria
L2ListA1,A2,A3,A4
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Put the following code in the events of your sheet.
If the data is not in the cells as you put it in your examples, then you need to adjust the ranges in the code.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("L2, O2")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim tot As Double
    Dim i As Long, j As Long
    Dim cad As String
      
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
    
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
        
    Application.EnableEvents = False
    Range(Target.Offset(1), Cells(Rows.Count, Target.Column + 1).End(3)(2)).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        j = j + 1
        c(j, 1) = b(i, 2)
        c(j, 2) = b(i, 3) * dic(cad)
        tot = tot + c(j, 2)
      End If
    Next
    If j > 0 Then
      Cells(3, Target.Column).Resize(j, 2).Value = c
      Cells(3 + j, Target.Column + 1).Value = tot
    End If
    Application.EnableEvents = True
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.
 
Upvote 0
DanteAmor said:
Put the following code in the events of your sheet.
If the data is not in the cells as you put it in your examples, then you need to adjust the ranges in the code.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("L2, O2")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim tot As Double
    Dim i As Long, j As Long
    Dim cad As String
     
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
   
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
   
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
       
    Application.EnableEvents = False
    Range(Target.Offset(1), Cells(Rows.Count, Target.Column + 1).End(3)(2)).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        j = j + 1
        c(j, 1) = b(i, 2)
        c(j, 2) = b(i, 3) * dic(cad)
        tot = tot + c(j, 2)
      End If
    Next
    If j > 0 Then
      Cells(3, Target.Column).Resize(j, 2).Value = c
      Cells(3 + j, Target.Column + 1).Value = tot
    End If
    Application.EnableEvents = True
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.
Click to expand...
@DanteAmor Thanks so much for the code. It works very well! I have two questions.

Can I ask how would I remove the sum at the end of the column on Target page? Which code is creating that sum?

I would like to change how the Target page looks to the following where A1 is the field to choose the portfolio and the results start at B3 with the corresponding weights at C3. Is that posible?

Many Thanks,

GG

CPWA - Portfolio Uploader 1.xlsm
ABC
1*80 Growth
2Model NameSymbolWeight
3 
4 
5 
6 
7 
8 
9 
10 
Portfolios
Cell Formulas
RangeFormula
A2A2="Model Name"
A3:A10A3
 
Upvote 0
GuyGadois said:
Can I ask how would I remove the sum at the end of the column on Target page? Which code is creating that sum?
Click to expand...
This line:
Cells(3 + j, Target.Column + 1).Value = tot


Try this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim tot As Double
    Dim i As Long, j As Long
    Dim cad As String
      
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
    
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
        
    Application.EnableEvents = False
    Range("B3:C" & Rows.Count).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        j = j + 1
        c(j, 1) = b(i, 2)
        c(j, 2) = b(i, 3) * dic(cad)
        'tot = tot + c(j, 2)
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(j, 2).Value = c
      'Cells(3 + j, Target.Column + 1).Value = tot
    End If
    Application.EnableEvents = True
  End If
End Sub
 
Upvote 0
DanteAmor said:
This line:
Cells(3 + j, Target.Column + 1).Value = tot


Try this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim tot As Double
    Dim i As Long, j As Long
    Dim cad As String
     
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
   
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
   
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
       
    Application.EnableEvents = False
    Range("B3:C" & Rows.Count).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        j = j + 1
        c(j, 1) = b(i, 2)
        c(j, 2) = b(i, 3) * dic(cad)
        'tot = tot + c(j, 2)
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(j, 2).Value = c
      'Cells(3 + j, Target.Column + 1).Value = tot
    End If
    Application.EnableEvents = True
  End If
End Sub
Click to expand...
@DanteAmor Oh, that makes total sense. Thank you.

I have noticed that the results are causing a problem in some instances. This is not a problem in the code but rather when two or more sub models have the same security it displays them both in the list as intended. If this happens is there a way to automatically sum the weight together so each ticker is just listed once and not twice (or more) because they appear on multiple sub portfolios?

Example:

CPWA - Portfolio Uploader 2.xlsm
ABC
1*99 Growth
2ModelSymbolWeight
3*99 GrowthAAPL0.94%
4*99 GrowthACN0.52%
5*99 GrowthADP0.60%
6*99 GrowthBX0.68%
7*99 GrowthC0.42%
8*99 GrowthCMG0.60%
9*99 GrowthCOST0.46%
10*99 GrowthCTLT0.30%
11*99 GrowthDHR0.50%
12*99 GrowthEA0.24%
13*99 GrowthEL0.52%
14*99 GrowthFB0.68%
15*99 GrowthHON0.44%
16*99 GrowthKO0.38%
17*99 GrowthLULU0.36%
18*99 GrowthMA0.42%
19*99 GrowthMAS0.46%
20*99 GrowthMCK0.38%
21*99 GrowthMRVL0.72%
22*99 GrowthMSFT0.64%
23*99 GrowthNFLX0.54%
24*99 GrowthNKE0.56%
25*99 GrowthNVDA1.06%
26*99 GrowthPFE0.50%
27*99 GrowthPXD0.52%
28*99 GrowthTGT0.58%
29*99 GrowthTSM0.52%
30*99 GrowthUNP0.50%
31*99 GrowthZTS0.54%
32*99 GrowthPRU0.30%
33*99 GrowthDUK0.32%
34*99 GrowthLLY0.66%
35*99 GrowthCC0.50%
36*99 GrowthMU0.52%
37*99 GrowthTMUS0.42%
38*99 GrowthAMP0.82%
39*99 GrowthJ0.48%
40*99 GrowthSPG0.40%
41*99 GrowthLMGNX9.00%
42*99 GrowthOAYIX9.00%
43*99 GrowthJEMSX7.00%
44*99 GrowthASPZX4.50%
45*99 GrowthIVV4.50%
46*99 GrowthQQQ4.80%
47*99 GrowthPRBLX4.80%
48*99 GrowthNBPIX11.40%
49*99 GrowthPICMX10.00%
50*99 GrowthASCZX5.00%
51*99 GrowthACVIX5.00%
52*99 GrowthAAPL2.50%
53*99 GrowthMSFT2.50%
Portfolios
Cell Formulas
RangeFormula
A3:A53A3=IF(B3="","",Allocation_Model_Name)
Named Ranges
NameRefers ToCells
Allocation_Model_Name=Portfolios!$A$1A3:A53
Cells with Data Validation
CellAllowCriteria
A1List=Models


A hopeful solution where column D has a * if it is contained in more than one sub portfolio.

CPWA - Portfolio Uploader 2.xlsm
ABCD
1*99 Growth
2ModelSymbolWeight
3*99 GrowthAAPL3.44%*
4*99 GrowthMSFT3.14%*
5*99 GrowthACN0.52%
6*99 GrowthADP0.60%
7*99 GrowthBX0.68%
8*99 GrowthC0.42%
9*99 GrowthCMG0.60%
10*99 GrowthCOST0.46%
11*99 GrowthCTLT0.30%
12*99 GrowthDHR0.50%
13*99 GrowthEA0.24%
14*99 GrowthEL0.52%
15*99 GrowthFB0.68%
16*99 GrowthHON0.44%
17*99 GrowthKO0.38%
18*99 GrowthLULU0.36%
19*99 GrowthMA0.42%
20*99 GrowthMAS0.46%
21*99 GrowthMCK0.38%
22*99 GrowthMRVL0.72%
23*99 GrowthNFLX0.54%
24*99 GrowthNKE0.56%
25*99 GrowthNVDA1.06%
26*99 GrowthPFE0.50%
27*99 GrowthPXD0.52%
28*99 GrowthTGT0.58%
29*99 GrowthTSM0.52%
30*99 GrowthUNP0.50%
31*99 GrowthZTS0.54%
32*99 GrowthPRU0.30%
33*99 GrowthDUK0.32%
34*99 GrowthLLY0.66%
35*99 GrowthCC0.50%
36*99 GrowthMU0.52%
37*99 GrowthTMUS0.42%
38*99 GrowthAMP0.82%
39*99 GrowthJ0.48%
40*99 GrowthSPG0.40%
41*99 GrowthLMGNX9.00%
42*99 GrowthOAYIX9.00%
43*99 GrowthJEMSX7.00%
44*99 GrowthASPZX4.50%
45*99 GrowthIVV4.50%
46*99 GrowthQQQ4.80%
47*99 GrowthPRBLX4.80%
48*99 GrowthNBPIX11.40%
49*99 GrowthPICMX10.00%
50*99 GrowthASCZX5.00%
51*99 GrowthACVIX5.00%
Portfolios
Cell Formulas
RangeFormula
A3:A51A3=IF(B3="","",Allocation_Model_Name)
Named Ranges
NameRefers ToCells
Allocation_Model_Name=Portfolios!$A$1A3:A51
Cells with Data Validation
CellAllowCriteria
A1List=Models


Many, Many Thanks,

GG
 
Upvote 0
GuyGadois said:
If this happens is there a way to automatically sum the weight
Click to expand...
Try this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object, dic2 As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim i As Long, j As Long
    Dim cad As String
     
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
   
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
   
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    dic2.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
       
    Application.EnableEvents = False
    Range("B3:C" & Rows.Count).ClearContents
    
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        If Not dic2.exists(b(i, 2)) Then
          j = j + 1
          dic2(b(i, 2)) = j
          c(j, 1) = b(i, 2)
          c(j, 2) = b(i, 3) * dic(cad)
        Else
          j = dic2(b(i, 2))
          c(j, 2) = c(j, 2) + (b(i, 3) * dic(cad))
        End If
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(dic2.Count, 2).Value = c
    End If
    Application.EnableEvents = True
  End If
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object, dic2 As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim i As Long, j As Long
    Dim cad As String
    
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
  
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
  
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    dic2.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
      
    Application.EnableEvents = False
    Range("B3:C" & Rows.Count).ClearContents
   
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        If Not dic2.exists(b(i, 2)) Then
          j = j + 1
          dic2(b(i, 2)) = j
          c(j, 1) = b(i, 2)
          c(j, 2) = b(i, 3) * dic(cad)
        Else
          j = dic2(b(i, 2))
          c(j, 2) = c(j, 2) + (b(i, 3) * dic(cad))
        End If
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(dic2.Count, 2).Value = c
    End If
    Application.EnableEvents = True
  End If
End Sub
Click to expand...
@DanteAmor Hi Dante, I wanted to see if you could assist with a slight change to the code. I would like to add one more column of data to the result when the cell is updated. If you recall, when the cell is changed it grabs the information and creates a new list. The two columns it creates is the Ticker Symbol and the Target Weight. What I would like to have is an additional column which is the "Sub Model Name" which is the column B in the source. I would like to display that in column B also on the sheet. Is this possible with the code?

Cheers,

GG

Here is the code I have that works as is:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object, dic2 As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim i As Long, j As Long
    Dim cad As String

    'data on sheet1
    Set sh1 = Sheets("CPWA - Allocation Model Members")
    a = sh1.Range("A2:C" & sh1.Range("A" & Rows.Count).End(3).Row).Value 'Range A2:C" incorporates the new column I want to bring over

    'data on sheet2
    Set sh2 = Sheets("CPWA - Security Level Models")
    b = sh2.Range("A5:C" & sh2.Range("A" & Rows.Count).End(3).Row).Value 'CHANGED to 5
    ReDim c(1 To UBound(b, 1), 1 To 2)
    
   
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    dic2.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
       
    Application.EnableEvents = False
    Range("B5:C" & Rows.Count).ClearContents 'CHANGED
    
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        If Not dic2.exists(b(i, 2)) Then
          j = j + 1
          dic2(b(i, 2)) = j
          c(j, 1) = b(i, 2)
          c(j, 2) = b(i, 3) * dic(cad)
        Else
          j = dic2(b(i, 2))
          c(j, 2) = c(j, 2) + (b(i, 3) * dic(cad))
        End If
      End If
    Next
    If j > 0 Then
      Range("B5").Resize(dic2.Count, 2).Value = c 'CHANGED
    End If
    Application.EnableEvents = True
  End If
End Sub
 
Upvote 0
GuyGadois said:
just wanted to see if you could help me out with this change I was looking to make.
Click to expand...

Try this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object, dic2 As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim i As Long, j As Long
    Dim cad As String
      
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
    
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 2)
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    dic2.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
        
    Application.EnableEvents = False
    Range("B3:C" & Rows.Count).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        If Not dic2.exists(b(i, 2)) Then
          j = j + 1
          dic2(b(i, 2)) = j
          c(j, 1) = b(i, 2)
          c(j, 2) = b(i, 3) * dic(cad)
        Else
          j = dic2(b(i, 2))
          c(j, 2) = c(j, 2) + (b(i, 3) * dic(cad))
        End If
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(dic2.Count, 2).Value = c
    End If
    Application.EnableEvents = True
  End If
End Sub
 
Upvote 0
I didn't paste the updated code.
Here is the correct one:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, Range("A1")) Is Nothing Then
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim dic As Object, dic2 As Object
    Dim a As Variant, b As Variant, c As Variant
    Dim i As Long, j As Long
    Dim cad As String
      
    'data on sheet1
    Set sh1 = Sheets("Sheet1")
    a = sh1.Range("H3:J" & sh1.Range("H" & Rows.Count).End(3).Row).Value
    
    'data on sheet2
    Set sh2 = Sheets("Sheet2")
    b = sh2.Range("H17:J" & sh2.Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 3)
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    dic2.comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2)) = a(i, 3)
    Next
        
    Application.EnableEvents = False
    Range("B3:D" & Rows.Count).ClearContents
    For i = 1 To UBound(b, 1)
      cad = Target.Value & "|" & b(i, 1)
      If dic.exists(cad) Then
        If Not dic2.exists(b(i, 2)) Then
          j = j + 1
          dic2(b(i, 2)) = j
          c(j, 1) = b(i, 1)
          c(j, 2) = b(i, 2)
          c(j, 3) = b(i, 3) * dic(cad)
        Else
          j = dic2(b(i, 2))
          c(j, 3) = c(j, 3) + (b(i, 3) * dic(cad))
        End If
      End If
    Next
    If j > 0 Then
      Range("B3").Resize(dic2.Count, 3).Value = c
    End If
    Application.EnableEvents = True
  End If
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Count - specific consecutive order
Replies
6
Views
512
Peter_SSs
Peter_SSs
M
  • Solved
Clear content in multiple ranges on 14 different worksheets.
Replies
7
Views
565
MAP77
M
A
  • Solved
Help with macros to open many files, and extract data. Need help with match / find.
Replies
9
Views
964
johnnyL
J
G
  • Solved
Create List from Range Based on Cell Value
Replies
3
Views
2K
Peter_SSs
Peter_SSs
S
  • Question
Creating a dynamic Subject line from information in a particular Excel column
Replies
0
Views
393
StevieMP
S

Forum statistics

Threads
1,214,954
Messages
6,122,462
Members
449,085
Latest member
ExcelError

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