Copier infos et mise en forme pour Index
K
Bonjour,
J'aimerais copier-coller le style "rayé" des cellules dans les feuilles des projets, pour les mettre dans mon bel index
Le problème est que je n'arrive pas à atteindre les cellules concernées.
Voyez-vous, dans toutes les feuilles concernant les projets, j'ai une petite section "Tower" A12:D12.
La cellule A12 peut prendre deux valeurs: "PCT" et "Steel".
Si "Steel" est sélectionné, les cellules vont être rayées! J'aimerais reprendre ces rayures et les coller dans l'index (feuille "Overview").
Merci d'avance pour votre aide.
KamazZ
Salut KamazZ,
comme ceci?
Sub MAJindex()
'
Dim F As Worksheet
Dim L As Integer, iRow As Integer
'
Application.ScreenUpdating = False
Application.EnableEvents = False
'
With Sheets("Overview")
L = 2
iRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A4:H" & iRow).ClearContents
.Range("A4:H" & iRow).Interior.Color = RGB(255, 255, 255)
.Range("A4:H" & iRow).Interior.Pattern = xlNone
'
For Each F In Worksheets
If F.Name <> "Index" And F.Name <> "Email" And F.Name <> "Feuille Modèle" Then
L = L + 1
.Cells(L, 1) = F.Cells(7, 1)
.Cells(L, 2) = F.Cells(7, 2)
.Cells(L, 3) = F.Cells(7, 3)
.Cells(L, 4) = F.Cells(12, 4)
.Cells(L, 5) = F.Cells(12, 2)
.Cells(L, 6) = F.Cells(12, 7)
.Cells(L, 7) = F.Cells(12, 5)
.Cells(L, 8) = F.Cells(1, 5)
'
'Hachurage
.Cells(L, 4).Interior.Pattern = IIf(F.Cells(12, 1) = "Steel", xlLightUp, xlSolid)
'.Range("A" & L & ":H" & L).Interior.Pattern = IIf(F.Cells(12, 1) = "Steel", xlLightUp, xlSolid)
'
' Mise en couleur des DOS
.Cells(L, 4).Interior.ColorIndex = F.Cells(12, 4).Interior.ColorIndex
.Cells(L, 5).Interior.ColorIndex = F.Cells(12, 4).Interior.ColorIndex
.Cells(L, 6).Interior.ColorIndex = F.Cells(12, 7).Interior.ColorIndex
.Cells(L, 7).Interior.ColorIndex = F.Cells(12, 7).Interior.ColorIndex
End If
Next
'
'En -Tête
.Cells(3, 1) = "Project N°"
.Cells(3, 2) = "Name"
.Cells(3, 3) = "LoCo"
.Cells(3, 4) = "Tower DOS"
.Cells(3, 5) = "Tower Forwarder"
.Cells(3, 6) = "WEC DOS"
.Cells(3, 7) = "WEC Forwarder"
.Cells(3, 8) = "Last update"
'
Range("Tableau1[[#Headers]]").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End SubSi le hachurage doit se répercuter sur toute la ligne dans 'OVERVIEW", alors choisir la ligne sous commentaire
A+