Re,
Tu testes en cliquant sur le bouton.
Sub AstralMacron()
Dim aa, jup(), mar(), j%, m%, i%, clr&
aa = ActiveSheet.Range("A2").CurrentRegion
ReDim jup(0): j = 1
jup(0) = WorksheetFunction.Index(aa, 1, 0)
ReDim mar(0): m = 1
mar(0) = WorksheetFunction.Index(aa, 1, 0)
For i = 2 To UBound(aa)
If aa(i, 3) = "JUPITER" Then
ReDim Preserve jup(j)
jup(j) = WorksheetFunction.Index(aa, i, 0)
j = j + 1
'aa(i, 1) = Empty
ElseIf aa(i, 3) = "MARS" Then
ReDim Preserve mar(m)
mar(m) = WorksheetFunction.Index(aa, i, 0)
m = m + 1
'aa(i, 1) = Empty
End If
Next i
clr = RGB(218, 238, 243)
With Worksheets(2).Range("A1")
.CurrentRegion.Clear
With .Resize(j, UBound(aa, 2))
.Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(jup))
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
With .Rows(1)
.Interior.Color = clr
.Font.Bold = True
End With
End With
End With
With Worksheets(3).Range("A1")
.CurrentRegion.Clear
With .Resize(m, UBound(aa, 2))
.Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(mar))
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
With .Rows(1)
.Interior.Color = clr
.Font.Bold = True
End With
End With
End With
'With ActiveSheet
'With .Range("A2").CurrentRegion
'.Value = aa
'.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'End With
'End With
End Sub
En l'état la macro ne supprime pas les JUPITER et MARS de Feuil1.
Pour qu'ils soient supprimés, activer les lignes du code qui sont désactivées : supprimer les apostrophes qui précèdent les lignes de code qui en ont une.
Cordialement.