I will call these ranges 'builds.' There are 2 builds in this code below, and I need to extend it to 25. I have written the code to make it work for 25, but it's so long, so it needs to be optimised. As you can see, the ranges will always be the same, apart from the last build, which are essentially mirrored 25 times.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if the change occurred in cell B6 or B22
If Target.Address = "$B$6" Or Target.Address = "$B$22" Then
' Clear existing comments in N17 and N6 or N33 and N22
If Target.Address = "$B$6" Then
Range("N17").ClearComments
Range("N6").ClearComments
ElseIf Target.Address = "$B$22" Then
Range("N33").ClearComments
Range("N22").ClearComments
End If
' Define ranges for suppliers (K10:K16), products (E10:E16), quantities (D10:D16), costs (M10:M16), and hyperlinks (L10:L16)
Dim supplierRange As Range
Dim productRange As Range
Dim quantityRange As Range
Dim costRange As Range
Dim hyperRange As Range
If Target.Address = "$B$6" Then
Set supplierRange = Range("K10:K16")
Set productRange = Range("E10:E16")
Set quantityRange = Range("D10:D16")
Set costRange = Range("M10:M16")
Set hyperRange = Range("L10:L16")
ElseIf Target.Address = "$B$22" Then
Set supplierRange = Range("K26:K32")
Set productRange = Range("E26:E32")
Set quantityRange = Range("D26:D32")
Set costRange = Range("M26:M32")
Set hyperRange = Range("L26:L32")
End If
' Create a dictionary to store unique products and corresponding quantities, costs, and hyperlinks for each supplier
Dim productsDict As Object
Set productsDict = CreateObject("Scripting.Dictionary")
' Loop through each cell in the supplier range
Dim cell As Range
For Each cell In supplierRange
' Check if the supplier exists in the dictionary
If Not productsDict.Exists(cell.value) Then
' Check if the corresponding quantity, cost, and hyperlink cells have values
If quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" And costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" And hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value <> "" Then
' If the quantity, cost, and hyperlink cells have values, add them to the dictionary with the corresponding product
productsDict.Add cell.value, quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value & " - £" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00") & vbCrLf & hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value
ElseIf quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" And costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" Then
' If only the quantity and cost cells have values, add them to the dictionary with the corresponding product
productsDict.Add cell.value, quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value & " - £" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00")
ElseIf quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" Then
' If only the quantity cell has a value, add it to the dictionary with the corresponding product
productsDict.Add cell.value, quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value
ElseIf costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" Then
' If only the cost cell has a value, add it to the dictionary with the corresponding product
productsDict.Add cell.value, "£" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00") & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value
ElseIf hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value <> "" Then
' If only the hyperlink cell has a value, add it to the dictionary with the corresponding product
productsDict.Add cell.value, hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value
End If
Else
' Check if the corresponding quantity, cost, and hyperlink cells have values
If quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" And costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" And hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value <> "" Then
' If the quantity, cost, and hyperlink cells have values, append them to the existing value
productsDict(cell.value) = productsDict(cell.value) & vbCrLf & quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value & " - £" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00") & vbCrLf & hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value
ElseIf quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" And costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" Then
' If only the quantity and cost cells have values, append them to the existing value
productsDict(cell.value) = productsDict(cell.value) & vbCrLf & quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value & " - £" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00")
ElseIf quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value <> "" Then
' If only the quantity cell has a value, append it to the existing value
productsDict(cell.value) = productsDict(cell.value) & vbCrLf & quantityRange.Cells(cell.Row - quantityRange.Row + 1, 1).value & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value
ElseIf costRange.Cells(cell.Row - costRange.Row + 1, 1).value <> "" Then
' If only the cost cell has a value, append it to the existing value
productsDict(cell.value) = productsDict(cell.value) & vbCrLf & "£" & Format(costRange.Cells(cell.Row - costRange.Row + 1, 1).value, "0.00") & " - " & productRange.Cells(cell.Row - productRange.Row + 1, 1).value
ElseIf hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value <> "" Then
' If only the hyperlink cell has a value, append it to the existing value
productsDict(cell.value) = productsDict(cell.value) & vbCrLf & hyperRange.Cells(cell.Row - hyperRange.Row + 1, 1).value
End If
End If
Next cell
' Create the comment text for cell N17 or N33
Dim commentTextN17OrN33 As String
For Each key In productsDict.Keys
commentTextN17OrN33 = commentTextN17OrN33 & key & ":" & vbCrLf & productsDict(key) & vbCrLf & vbCrLf
Next key
' Include the value of cell N17 or N33 at the end of the comment
If Target.Address = "$B$6" Then
commentTextN17OrN33 = commentTextN17OrN33 & "Each: £" & Format(Range("N17").value, "0.00")
Dim commentShapeN17 As Shape
Set commentShapeN17 = Range("N17").AddComment(commentTextN17OrN33).Shape
commentShapeN17.TextFrame.AutoSize = True ' Allow the text box to adjust size based on content
commentShapeN17.Height = 300 ' Set the desired height in points
commentShapeN17.Width = 300 ' Set the desired width in points
ElseIf Target.Address = "$B$22" Then
commentTextN17OrN33 = commentTextN17OrN33 & "Each: £" & Format(Range("N33").value, "0.00")
Dim commentShapeN33 As Shape
Set commentShapeN33 = Range("N33").AddComment(commentTextN17OrN33).Shape
commentShapeN33.TextFrame.AutoSize = True ' Allow the text box to adjust size based on content
commentShapeN33.Height = 300 ' Set the desired height in points
commentShapeN33.Width = 300 ' Set the desired width in points
End If
' Create the comment text for cell N6 or N22
Dim commentTextN6OrN22 As String
If Target.Address = "$B$6" Then
commentTextN6OrN22 = "Based on " & Range("B8").value & " a day. "
Dim commentShapeN6 As Shape
On Error Resume Next ' In case N6 doesn't have an existing comment
Set commentShapeN6 = Range("N6").Comment.Shape
On Error GoTo 0
If commentShapeN6 Is Nothing Then
Set commentShapeN6 = Range("N6").AddComment(commentTextN6OrN22).Shape
commentShapeN6.TextFrame.AutoSize = True
commentShapeN6.Height = 25 ' Set the desired height in points
commentShapeN6.Width = 100 ' Set the desired width in points
Else
commentShapeN6.TextFrame.Characters.Text = commentTextN6OrN22
End If
ElseIf Target.Address = "$B$22" Then
commentTextN6OrN22 = "Based on " & Range("B24").value & " a day. "
Dim commentShapeN22 As Shape
On Error Resume Next ' In case N22 doesn't have an existing comment
Set commentShapeN22 = Range("N22").Comment.Shape
On Error GoTo 0
If commentShapeN22 Is Nothing Then
Set commentShapeN22 = Range("N22").AddComment(commentTextN6OrN22).Shape
commentShapeN22.TextFrame.AutoSize = True
commentShapeN22.Height = 25 ' Set the desired height in points
commentShapeN22.Width = 100 ' Set the desired width in points
Else
commentShapeN22.TextFrame.Characters.Text = commentTextN6OrN22
End If
End If
End If
End Sub
Last edited by a moderator:
