How to plot relative positions in excel?

[mentorman]

I want to enter references in a table (RH side of picture) and have them show up in the relative cells in the plot area with same colour and reference shown.Sorry colours didn't paste but want the colour of the letter to be matched on the plot as well as the letter, When a reference changes I want to see it in relations to the others. So it needs to be constantly changes as A,B,C etc change in position. The plot area could be up to 100 x 100 cells.

Help! is this even possible in excel?

Plotting?
A	row	column			1	2	3	4	5	6	7	8
ref	3	17		10
B	row	column		11
ref	6	12		12						B
c	row	column		13	C
ref	1	13		14				F				D
D	row	column		15
ref	8	14		16
E	row	column		17			A
ref	6	18		18						E
F	row	column		19
ref	4	14		20

<colgroup><col width="64" span="4" style="width:48pt"> <col width="64" style="width:48pt"> <col width="64" span="8" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[mentorman]

Sorry should read LH side of diagram as couldn't upload picture

 

[MickG]

'With your left hand Table starting in "A2", and your right hand table Starting in row 2 column "E" (i.e "E2" which is actually a blank cell) this code should return the column and row values to the left hand table.
'Place the code in the "Worksheet Module"
NB:- For a larger range, change the Range "Rng" address to suit. The code will automatically look at all the data in column "A".

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim Lst As Long
Dim Dic As Object
Lst = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("F3:M13")
If Not Intersect(Target, Rng) Is Nothing Then
    Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
For Each Dn In Rng: Set Dic.Item(Dn.Value) = Dn: Next


For n = 2 To Lst Step 2
    With Range("A" & n)
        If Dic.exists(.Value) Then
            .Offset(1, 1).Value = Dic.Item(.Value).Column - 5
            .Offset(1, 2).Value = Dic.Item(.Value).Row + 7
        End If
    End With
 Next n
 End If
End Sub

 

[NewOrderFac33]

My solution isn't as elegant, and I haven't figured out the colours yet, but assuming you have a table in B3:D10 where:
B3:B10 contains your labels and has a worksheet name "Labels",
C3:C10 contains the Row references and has a worksheet name "Rows" and
D3:D10 contains your Column references and has a worksheet name "Columns"

the following works nicely and will react to changes in Row/Column references, or changes to the labels themselves:

Dim CurrentPlotLabel As String
Dim CurrentPlotRow As Long
Dim CurrentPlotColumn As Long

Dim NewPlotLabel As String
Dim NewPlotRow As Long
Dim NewPlotColumn As Long


'Store the current label, Row value and Column value from the table
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("Labels")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, 0).Value
            CurrentPlotRow = Target.Offset(0, 1).Value
            CurrentPlotColumn = Target.Offset(0, 2).Value
        End If
        
        If Not Intersect(Target, Range("Rows")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, -1).Value
            CurrentPlotRow = Target.Offset(0, 0).Value
            CurrentPlotColumn = Target.Offset(0, 1).Value
        End If
    
        If Not Intersect(Target, Range("Columns")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, -2).Value
            CurrentPlotRow = Target.Offset(0, -1).Value
            CurrentPlotColumn = Target.Offset(0, 0).Value
        End If
    End If

End Sub


'Clear the value in Cells(CurrentPlotRow, CurrentPlotColumn)
'Replace it with the amended Label in Cells(NewPlotRow, NewPlotColumn) as required
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("Labels")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            NewPlotRow = Target.Offset(0, 1).Value
            NewPlotColumn = Target.Offset(0, 2).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, 0).Formula
        End If
        
        If Not Intersect(Target, Range("Rows")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            NewPlotRow = Target.Offset(0, 0).Value
            NewPlotColumn = Target.Offset(0, 1).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, -1).Formula
        End If
    
        If Not Intersect(Target, Range("Columns")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            NewPlotRow = Target.Offset(0, -1).Value
            NewPlotColumn = Target.Offset(0, 0).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, -2).Formula
        End If
    End If

End Sub

Hope this helps

Pete

 

[MickG]

Sorry , I forgot the colouring, Pete's code reminded me, Try this:-

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim Lst As Long
Dim Dic As Object
Lst = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("F3:M13")
If Not Intersect(Target, Rng) Is Nothing Then
    Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
For Each Dn In Rng: Set Dic.Item(Dn.Value) = Dn: Next


For n = 2 To Lst Step 2
    With Range("A" & n)
        If Dic.exists(.Value) Then
            .Offset(1, 1).Value = Dic.Item(.Value).Column - 5
            .Offset(1, 1).Interior.ColorIndex = Dic.Item(.Value).Interior.ColorIndex
            .Offset(1, 2).Value = Dic.Item(.Value).Row + 7
            .Offset(1, 2).Interior.ColorIndex = Dic.Item(.Value).Interior.ColorIndex
        End If
    End With
 Next n
 End If
End Sub

 

[NewOrderFac33]

Touche!

Option Explicit

Dim CurrentPlotLabel As String
Dim CurrentPlotRow As Long
Dim CurrentPlotColumn As Long
Dim CurrentColorIndex As Long

Dim NewPlotLabel As String
Dim NewPlotRow As Long
Dim NewPlotColumn As Long

'Store the current Label, Row, Column and .Interior.ColorIndex of the currently selected cell
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("Labels")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, 0).Value
            CurrentColorIndex = Target.Offset(0, 0).Interior.ColorIndex
            CurrentPlotRow = Target.Offset(0, 1).Value
            CurrentPlotColumn = Target.Offset(0, 2).Value
        End If
        
        If Not Intersect(Target, Range("Rows")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, -1).Value
            CurrentColorIndex = Target.Offset(0, -1).Interior.ColorIndex
            CurrentPlotRow = Target.Offset(0, 0).Value
            CurrentPlotColumn = Target.Offset(0, 1).Value
        End If
    
        If Not Intersect(Target, Range("Columns")) Is Nothing Then
            CurrentPlotLabel = Target.Offset(0, -2).Value
            CurrentColorIndex = Target.Offset(0, -2).Interior.ColorIndex
            CurrentPlotRow = Target.Offset(0, -1).Value
            CurrentPlotColumn = Target.Offset(0, 0).Value
        End If
    End If

End Sub

'Clear the value and .Interior.ColorIndex in Cells(CurrentPlotRow, CurrentPlotColumn)
'Replace it with the amended Label and .Interior.ColorIndex in Cells(NewPlotRow, NewPlotColumn) as required
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("Labels")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            Cells(CurrentPlotRow, CurrentPlotColumn).Interior.ColorIndex = xlNone
            NewPlotRow = Target.Offset(0, 1).Value
            NewPlotColumn = Target.Offset(0, 2).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, 0).Formula
            Cells(NewPlotRow, NewPlotColumn).Interior.ColorIndex = CurrentColorIndex
        End If
        
        If Not Intersect(Target, Range("Rows")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            Cells(CurrentPlotRow, CurrentPlotColumn).Interior.ColorIndex = xlNone
            NewPlotRow = Target.Offset(0, 0).Value
            NewPlotColumn = Target.Offset(0, 1).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, -1).Formula
            Cells(NewPlotRow, NewPlotColumn).Interior.ColorIndex = CurrentColorIndex
        End If
    
        If Not Intersect(Target, Range("Columns")) Is Nothing Then
            Cells(CurrentPlotRow, CurrentPlotColumn).ClearContents
            Cells(CurrentPlotRow, CurrentPlotColumn).Interior.ColorIndex = xlNone
            NewPlotRow = Target.Offset(0, -1).Value
            NewPlotColumn = Target.Offset(0, 0).Value
            Cells(NewPlotRow, NewPlotColumn).Formula = Target.Offset(0, -2).Formula
            Cells(NewPlotRow, NewPlotColumn).Interior.ColorIndex = CurrentColorIndex
        End If
    End If

End Sub

Pete