Raggruppare i fogli

Ciao
da quello che ho capito, vuoi creare (dal tuo esempio) 4 file con ciascuno all'interno x fogli dello stesso colore, quindi un file con tutti i fogli rossi, uno con tutti i fogli verdi ecc..ecc.

NOTA: crea una cartella in c e chiamala MiaCartella (oppure correggi il percorso nella macro dove salvare i file creati).
Tieni presente che ogni volta che esegui la macro, i file precedenti verranno sovrascritti, in virtù dell'istruzione:
Application.DisplayAlerts = False.

Fogli di colore diverso intrerrompono l'esecuzione.


Saluti

Sub SalvaFogli()
Dim mPath As String, NewWbk As Workbook, mName As String
Dim rArr(), vArr(), bArr(), gArr()
ReDim rArr(0)
ReDim vArr(0)
ReDim bArr(0)
ReDim gArr(0)

mPath = "C:\MiaCartella"
rosso = 192
verde = 5287936
blu = 13998939
giallo = 49407

For i = 1 To Sheets.Count
    Select Case Sheets(i).Tab.Color
        Case Is = rosso
            rArr(r) = Sheets(i).Name
            r = r + 1
            ReDim Preserve rArr(r)
        Case Is = verde
            vArr(v) = Sheets(i).Name
            v = v + 1
            ReDim Preserve vArr(v)
        Case Is = blu
            bArr(b) = Sheets(i).Name
            b = b + 1
            ReDim Preserve bArr(b)
        Case Is = giallo
            gArr(g) = Sheets(i).Name
            g = g + 1
            ReDim Preserve gArr(g)
        Case Else
            MsgBox "Sono presenti fogli con colori non previsti." & _
                    "Elaborazione interrotta"
            Exit Sub
    End Select
Next
ReDim Preserve rArr(LBound(rArr) To UBound(rArr) - 1)
ReDim Preserve vArr(LBound(vArr) To UBound(vArr) - 1)
ReDim Preserve bArr(LBound(bArr) To UBound(bArr) - 1)
ReDim Preserve gArr(LBound(gArr) To UBound(gArr) - 1)

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Sheets(rArr).Copy
ActiveWorkbook.SaveAs Filename:=mPath & "\" & "Rosso"
ActiveWorkbook.Close

Sheets(vArr).Copy
ActiveWorkbook.SaveAs Filename:=mPath & "\" & "Verde"
ActiveWorkbook.Close

Sheets(bArr).Copy
ActiveWorkbook.SaveAs Filename:=mPath & "\" & "Blu"
ActiveWorkbook.Close
   
Sheets(gArr).Copy
ActiveWorkbook.SaveAs Filename:=mPath & "\" & "Giallo"
ActiveWorkbook.Close
   
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub