VBA code to run over many rows and show shapes if the area is being used,

[richie247]

I have started writing a VBA code to check and see if an area is being used, (I have 52 areas) I have used a formula to see if it is true. the if it is true I get I to check another cell to see what the area is used for then change the color to the specified. the data could be a short as 10 lines on quite days and over 100 on busy days.

I think if I was to write the code it would take a long time having to change the cell references for every line.

here is a sample of the code i am using which works, i just need to try and simplify it

Sub ShowHideAreas()

If Worksheets("Sheet2").Range("G2").Value = True Then
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Visible = msoTrue
Else
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Visible = msoFalse
End If
If Worksheets("Sheet2").Range("G2").Value = True Then

If Worksheets("Sheet2").Range("C2") = "Yellow" Then
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0)
Else
If Worksheets("Sheet2").Range("C2") = "Blue" Then
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(51, 102, 255)
Else
If Worksheets("Sheet2").Range("C2") = "Red" Then
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
If Worksheets("Sheet2").Range("C2") = "Lavendar" Then
Worksheets("Sheet1").Shapes.Range(Array("Area_A1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(204, 153, 255)

End If
End If
End If
End If
End If
End sub

the range for each area will be from G2:BM2 (all shapes area free formed and name changed to Area_xx)then down and the cell for the use of the area will be C2:C:100.

Many thanks in advance

 

[DanteAmor]

The macro could be simplified to this, but I'm not sure of the relationship of row G2 to BM2 with column C2 to C100, you could explain with 3 areas what that relationship.

Sub ShowHideAreas()
  Dim i As Long, sh1 As Worksheet, sh2 As Worksheet, wRGB
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
 
  For i = 1 To 52
    sh1.Shapes.Range(Array("Area_A" & i)).Visible = sh2.Cells(2, Columns("G").Column + i - 1).Value
    If sh2.Cells(2, Columns("G").Column + i - 1).Value = True Then
      Select Case sh2.Cells(i + 1, "C")
        Case "Yellow":    wRGB = RGB(255, 255, 0)
        Case "Blue":      wRGB = RGB(51, 102, 255)
        Case "Red":       wRGB = RGB(255, 0, 0)
        Case "Lavendar":  wRGB = RGB(204, 153, 255)
      End Select
      sh1.Shapes.Range(Array("Area_A" & i)).Select
      Selection.ShapeRange.Fill.ForeColor.RGB = wRGB
    End If
  Next
End Sub

 

[richie247]

Hi Many thanks for that.

the lay out of the data sheet is attached.

each row is a booking for various people to book areas, 2:100
G to BM are the areas.
col C is the color code I will use to show different types of booking.

I need it to show all areas on different lines at the same time on the sheet 1. which I have a picture of the areas with the shape as an overlay.

again thanks for the help

hopefully this make sense.

 

[DanteAmor]

Unfortunately in your macro you just put an example, so I have to guess the relationships.
Better explain the relationships.
Cell C2 is for shapes "AreaA1" through "AreaA52"?
Cell C3 is for shapes "AreaB1" through "AreaB52"?

 

[richie247]

Unfortunately in your macro you just put an example, so I have to guess the relationships.
Better explain the relationships.
Cell C2 is for shapes "AreaA1" through "AreaA52"?
Cell C3 is for shapes "AreaB1" through "AreaB52"?

all the shapes are area A1 through A52
Cell C2 is for booking 1
Cell C3 is for booking 2
Cell C100 is for booking 99
the colors are for different activities so booking 1 and booking 25 could be doing the same thing but at different times. is this possible to do with 1 set of shapes? or would I have to copy and paste the shapes and rename them AREA B1 etc?

 

[DanteAmor]

I'm sorry, I still don't understand what you have.
You can explain what you have and what you want to do.

If you have this in your Sheet2

Book1
	A	B	C	D	E	F	G	H	I	J
1							a1	a2	a3	a4
2			Red				FALSE	TRUE	TRUE	TRUE
3			Blue				TRUE	FALSE	TRUE	TRUE
Sheet2

What should have happened on Sheet1.
I still can't imagine what you have on Sheet1 because you haven't put an example, you could put an example based on what I put in the example on sheet2.
You also tell me the name of each shape.

 

[richie247]

sheet 2

sheet 1

hopefully this will make sense, the areas could be any colour determined by what the value is in "C2:C100".

 

[DanteAmor]

Sorry, but I don't understand the logic.
If you have the following in sheet2, then would sheet1 be all hidden shapes?

Book1
	A	B	C	D	E	F	G	H	I	J
1	TIME	WHO	WHAT	WHERE			a1	a2	a3	a4
2	7	JOH	Red				TRUE	TRUE	TRUE	TRUE
3	730	PAUL	Blue				FALSE	FALSE	FALSE	FALSE
Sheet2

Or do you have 8 shapes 4 are for John and 4 are for Paul? What is the name of the shape of John and what is the name of the shape of Paul?
That's why I asked for the names of the shapes.

 

[richie247]

on sheet one I have 53 shapes which are all hidden. named Area_A1, Area_A2 through to Area_A53. they each correspond to a location on sheet 1.

in "G2" i us the following formula "=ISNUMBER(SEARCH(G$1,$D$2))" this is so I can add the areas that each person wants to use in "D".

so from what you have
all the shapes would be red

if you had row 2 a1, a2, a3 true and a4 false
and row 3 a1, a2, a3 false and a4 true

the output would be 3 red areas and 1 blue area.

 

[DanteAmor]

Try this please:

Sub ShowHideAreas()
  Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, j As Long
  Dim wRGB As Variant, shp As Object
  '
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  '
  sh1.Select
  For Each shp In sh1.Shapes
    If LCase(Left(shp.Name, 6)) = LCase("Area_A") Then
      shp.Visible = False
    End If
  Next
  '
  For i = 2 To sh2.Range("C" & Rows.Count).End(xlUp).Row
    For j = 1 To 52
      If sh2.Cells(i, Columns("G").Column + j - 1).Value = True Then
        sh1.Shapes.Range(Array("Area_A" & j)).Visible = True
        Select Case sh2.Range("C" & i)
          Case "Yellow":    wRGB = RGB(255, 255, 0)
          Case "Blue":      wRGB = RGB(51, 102, 255)
          Case "Red":       wRGB = RGB(255, 0, 0)
          Case "Lavendar":  wRGB = RGB(204, 153, 255)
        End Select
        sh1.Shapes.Range(Array("Area_A" & j)).Select
        Selection.ShapeRange.Fill.ForeColor.RGB = wRGB
      End If
    Next
  Next
  MsgBox "Done"
End Sub