Excel Macro kleuren formule + opmaak

Option Explicit

Private Sub CommandButton1_Click()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
Dim i As Integer, str As String
Dim arr
Range("V3:V1000").ClearContents
For i = 1 To Shapes.Count
        
        With Shapes(i)
        
        If .Type = msoGroup Then
        
          .Ungroup
          End If
          End With
          Next
For i = 1 To Shapes.Count
With Shapes(i)
If Left(.Name, 8) = "Freeform" Then
str = str & "/" & .Name
End If
End With
Next
str = Mid(str, 2)
arr = Split(str, "/")
Range("V3").Resize(UBound(arr) + 1) = Application.Transpose(arr)
For Each c In [U3:U92]
On Error Resume Next
    myStr = Right("000000" & Hex(c.Offset(0, -1).Interior.Color), 6)
    lRed = Application.Evaluate("=Hex2dec(""" & Right(myStr, 2) & """)")
    lGreen = Application.Evaluate("=Hex2dec(""" & Mid(myStr, 3, 2) & """)")
    lBlue = Application.Evaluate("=Hex2dec(""" & Left(myStr, 2) & """)")
    Shapes(c).Fill.ForeColor.RGB = RGB(lRed, lGreen, lBlue)
   
 
Next

End Sub

Private Sub CommandButton2_Click()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long




For Each c In [U3:U92]
On Error Resume Next
   
    
    Shapes(c).Fill.ForeColor.RGB = RGB(255, 255, 255)
 
Next
Range("V3:V1000").ClearContents
End Sub

Option Explicit

Sub ColorMap()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
Dim i As Integer, str As String
Dim arr
ActiveSheet.Range("U:U").ClearContents
For i = 1 To ActiveSheet.Shapes.Count
        
        With ActiveSheet.Shapes(i)
        'str = ActiveSheet.Shapes(i).Name
        If .Type = msoGroup Then
        
          .Ungroup
          End If
          End With
          Next
For i = 1 To ActiveSheet.Shapes.Count
With ActiveSheet.Shapes(i)
If Left(.Name, 8) = "Freeform" Then
str = str & "/" & .Name
End If
End With
Next
str = Mid(str, 2)
arr = Split(str, "/")
ActiveSheet.Range("U3").Resize(UBound(arr) + 1) = Application.Transpose(arr)
For Each c In [U3:U92]
On Error Resume Next
    myStr = Right("000000" & Hex(c.Offset(0, 1).Interior.Color), 6)
    lRed = Application.Evaluate("=Hex2dec(""" & Right(myStr, 2) & """)")
    lGreen = Application.Evaluate("=Hex2dec(""" & Mid(myStr, 3, 2) & """)")
    lBlue = Application.Evaluate("=Hex2dec(""" & Left(myStr, 2) & """)")
    ActiveSheet.Shapes(c).Fill.ForeColor.RGB = RGB(lRed, lGreen, lBlue)

Next

End Sub

Private Sub CommandButton1_Click()
  Range("V3:V1000").ClearContents

  For each it in Shapes
     if it.Type = msoGroup Then it.Ungroup
  Next

  For each it in Shapes
     If Left(it.Name, 8) = "Freeform" Then str = str & "/" & it.Name
  Next

  sn=split(Mid(str, 2),"/")
  Range("V3").Resize(UBound(sn) + 1) = Application.Transpose(sn)

  For Each c In [T3:T92]
    Shapes(c).Fill.ForeColor.RGB = c.Interior.Color
  Next
End Sub

Private Sub CommandButton2_Click()
   Sheet1.Shapes.Range([transpose(U3:U92)]).Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub

Private Sub CommandButton1_Click()
  ReDim sn(Sheet1.Shapes.Count, 0)
  
  For Each it In Shapes
     If it.Type = 5 Then
        sn(j, 0) = it.Name
        j = j + 1
     End If
  Next
  Range("V3").Resize(UBound(sn) + 1) = sn

  For Each c In [T3:T92]
      Shapes(c).Fill.ForeColor.RGB = c.Interior.Color
  Next
End Sub