gregfthompson
asked on
Small amendment to shape manipulation in Excel
The attached workbook contains a worksheet called Map that contains values in cells F1 to AN1, and F3 to AN3 and these cells are linked to cells in a worksheet called Adjustable Weighting Table.
A change in the value of the cell in Map, changes the all values in each column in the Adjustable Weighting Table.
In the Adjustable Weighting Table, the values in D5 to D179 are linked to the values in A5 to A179 - i.e. D5 is linked to A5.
And the value in D5 is linked to the size of the circle in Map on the map that has the same ID as the number in cell A5..
When a value in Map F1 to AB1 is changed, the size of the circles on the map also change.
This is also meant to occur for a change in value in cells AC1 to AN1, and F3 to AN3, but something is not working.
I would like a change in any value in AC1 to AN1, and F3 to AN3 to change the size of the circles ion the map.
E-Example-workbook.xlsm
A change in the value of the cell in Map, changes the all values in each column in the Adjustable Weighting Table.
In the Adjustable Weighting Table, the values in D5 to D179 are linked to the values in A5 to A179 - i.e. D5 is linked to A5.
And the value in D5 is linked to the size of the circle in Map on the map that has the same ID as the number in cell A5..
When a value in Map F1 to AB1 is changed, the size of the circles on the map also change.
This is also meant to occur for a change in value in cells AC1 to AN1, and F3 to AN3, but something is not working.
I would like a change in any value in AC1 to AN1, and F3 to AN3 to change the size of the circles ion the map.
E-Example-workbook.xlsm
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Ejgil got here first but change his line 2 to
If Not Intersect(Target, Range("F1:AI1", "F3:AI3")) Is Nothing And Target.Count = 1 Then
If Not Intersect(Target, Range("F1:AI1", "F3:AI3")) Is Nothing And Target.Count = 1 Then
The requirement was to column AN.
Guess it is going to be expanded.
Guess it is going to be expanded.
ASKER
Thanks to both.
Can you provide the full script. I can't work out where to include the change.
Can you provide the full script. I can't work out where to include the change.
In the code for the Map sheet you'll find this.
Replace it with Ejgil's code with or without my modification.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F1:AB1")) Is Nothing And Target.Count = 1 Then
Application.EnableEvents = False
UpdateMap_click
Application.EnableEvents = True
End If
End Sub
Replace it with Ejgil's code with or without my modification.
ASKER
Thanks Martin, but in the module, this is the entire code:
Sub UpdateMap_click()
Dim myShp As String
Dim i As Long
Dim lngLastDataRow As Long
Dim lngDataRows As Long
Const FIRST_DATE_ROW = 5
Const DEFAULT_SIZE = 0.04
Dim wsAdjust As Worksheet
Dim wsMap As Worksheet
Application.ScreenUpdating = False
On Error GoTo UpdateMap_click_Error
Set wsAdjust = Worksheets("Adjustable Weighting Table")
Set wsMap = Worksheets("Map")
lngLastDataRow = wsAdjust.Range("A1048576") .End(xlUp) .Row
lngDataRows = lngLastDataRow - FIRST_DATE_ROW + 1
For i = FIRST_DATE_ROW To lngLastDataRow
myShp = wsAdjust.Cells(i, "A").Value
wsMap.Shapes(myShp).Height = DEFAULT_SIZE * wsAdjust.Cells(i, "D").Value
wsMap.Shapes(myShp).Width = Sheets("Map").Shapes(myShp ).Height
Next i
' From here down is the rest of the error handling code
On Error GoTo 0
Exit Sub
UpdateMap_click_Error:
Application.EnableEvents = True
If Err.Number = -2147024809 Then
MsgBox "A shape with the name " & myShp & " is missing. Processing stopped.", _
vbOKOnly + vbExclamation, "Missing shape"
Debug.Print "Missing " & myShp
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure " _
& "UpdateMap_click of Module UpdateMapMacro"
End If
End Sub
Sub UpdateMap_click()
Dim myShp As String
Dim i As Long
Dim lngLastDataRow As Long
Dim lngDataRows As Long
Const FIRST_DATE_ROW = 5
Const DEFAULT_SIZE = 0.04
Dim wsAdjust As Worksheet
Dim wsMap As Worksheet
Application.ScreenUpdating
On Error GoTo UpdateMap_click_Error
Set wsAdjust = Worksheets("Adjustable Weighting Table")
Set wsMap = Worksheets("Map")
lngLastDataRow = wsAdjust.Range("A1048576")
lngDataRows = lngLastDataRow - FIRST_DATE_ROW + 1
For i = FIRST_DATE_ROW To lngLastDataRow
myShp = wsAdjust.Cells(i, "A").Value
wsMap.Shapes(myShp).Height
wsMap.Shapes(myShp).Width = Sheets("Map").Shapes(myShp
Next i
' From here down is the rest of the error handling code
On Error GoTo 0
Exit Sub
UpdateMap_click_Error:
Application.EnableEvents = True
If Err.Number = -2147024809 Then
MsgBox "A shape with the name " & myShp & " is missing. Processing stopped.", _
vbOKOnly + vbExclamation, "Missing shape"
Debug.Print "Missing " & myShp
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure " _
& "UpdateMap_click of Module UpdateMapMacro"
End If
End Sub
See the above but here's an updated workbook.
28960761.xlsm
28960761.xlsm
Thanks Martin, but in the module, this is the entire code:No. That's the Module1 code. The other code is in the Map sheet code.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank you both.
Brilliant job.
Brilliant job.
You're welcome and I'm glad I was able to help.
In my profile you'll find links to some articles I've written that may interest you.
Marty - Microsoft MVP 2009 to 2016
Experts Exchange MVE 2015
Experts Exchange Top Expert Visual Basic Classic 2012 to 2015
In my profile you'll find links to some articles I've written that may interest you.
Marty - Microsoft MVP 2009 to 2016
Experts Exchange MVE 2015
Experts Exchange Top Expert Visual Basic Classic 2012 to 2015
ASKER