1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
| Option Explicit
'
' Test existance feuille
'
Function FeuilleExiste(NomFeuille) As Boolean
On Error GoTo err
Debug.Print Sheets(NomFeuille).Name
FeuilleExiste = True
Exit Function
err:
FeuilleExiste = False
End Function
'
' Nom Feuille
'Fonction à Compléter détermine le nom de la feuille en fonction de la
' couleur donnée en paramétre
'
Function NomFeuille(iColor As Long) As String
Select Case iColor
Case 16777215 ' Sur fond blanc
NomFeuille = "Blanc"
Case Else
NomFeuille = "Couleur - " & iColor
End Select
End Function
'
' VerifieFeuille
' Verifie existence feuille et la crée si n'existe pas
Sub VerifieFeuille(stNom As String)
If Not FeuilleExiste(stNom) Then
Sheets.Add
ActiveSheet.Name = stNom
End If
End Sub
'
' iProchaineLigne
'Determine Prochaine Ligne
'
'
Function iProchaineLigne(stNomFeuille, stNomCellule) As Integer
Dim i As Integer
i = Sheets(stNomFeuille).Cells(65535, Range(stNomCellule).Column).End(xlUp).Row
If Not (i = 1 And Sheets(stNomFeuille).Range(stNomCellule).EntireColumn.Cells(1) = "") Then
i = i + 1 'Rajoute 1 à i sauf si 1° Cellule de la colonne et est vide..
End If
iProchaineLigne = i
End Function
' Macro de copie colonne E..
'
Sub MaMacro()
Dim rSource As Range ' Range Source de la copie
Dim c As Range
Dim st As String
Dim iL As Integer 'derniere ligne du fichier
Set rSource = Sheets("Feuil1").Range("E1:E220") ' A Adapter ...
For Each c In rSource
If c.Value <> "" Then ' Ne traite que les cellules non-vides..
Debug.Print c.Value
st = NomFeuille(c.Interior.Color)
VerifieFeuille (st)
iL = iProchaineLigne(st, "E1")
c.Parent.Activate 'Active.
c.EntireRow.Copy
Sheets(st).Activate
Cells(iL, 1).Select
ActiveSheet.Paste
End If
Next
End Sub |
Partager