good morning,
i have been running this code which works well however sometimes there will be times when there might be an over lap. i need it to display both colours or have the border the first colour.
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 "*******": wRGB = RGB(255, 204, 153)
Case "******* ": wRGB = RGB(255, 255, 0)
Case "*******": wRGB = RGB(51, 102, 255)
Case "*******": wRGB = RGB(255, 0, 0)
Case "*******": wRGB = RGB(204, 153, 255)
Case "*******": wRGB = RGB(255, 255, 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
many thanks in advance
i have been running this code which works well however sometimes there will be times when there might be an over lap. i need it to display both colours or have the border the first colour.
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 "*******": wRGB = RGB(255, 204, 153)
Case "******* ": wRGB = RGB(255, 255, 0)
Case "*******": wRGB = RGB(51, 102, 255)
Case "*******": wRGB = RGB(255, 0, 0)
Case "*******": wRGB = RGB(204, 153, 255)
Case "*******": wRGB = RGB(255, 255, 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
many thanks in advance