Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 Macro pour transférer des données d'un feuille à l'autre avec cellules colorées

Valoche54000

XLDnaute Nouveau
Bonjour la communauté,

Sur le fichier téléversé, avec la macro '' répartition '', j'essaie de transférer les données de la feuille principale à d'autres onglets.
les colonnes H,I,J,M se déverseront dans les 20 onglets portant le nom des équipes automatiquement dés lors de la mise à jour de l'onglet ''20172018''
Exemple Ligne 3: dans les onglets '' ACAjaccio'' et '' Niort '' nous aurons H3,I3,J3, et O3.
Jusque là, j'y arrive. par contre je ne comprends pas pourquoi les cellules colorées ne le sont plus une fois transférées dans les différents onglets.

Sub répartition()
Dim C As Range, Ligne As Long
For i = 2 To Sheets.Count
Sheets(i).[A: D].Clear
Next i
With Sheets("20172018")
For Each C In .Range("H3", .Cells(.Rows.Count, 8).End(xlUp))
If C.Value <> "" Then
With Sheets(C.Offset(, 1).Value)
Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If .[A1] = "" Then Ligne = 1
C.Resize(, 3).Copy .Cells(Ligne, 1)
C.Resize(, 3).Copy
.Cells(Ligne, 1).PasteSpecial xlPasteValues
C.Offset(, 5).Copy .Cells(Ligne, 4)
C.Offset(, 5).Copy
.Cells(Ligne, 4).PasteSpecial xlPasteValues
End With
With Sheets(C.Offset(, 2).Value)
Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If .[A1] = "" Then Ligne = 1
C.Resize(, 3).Copy .Cells(Ligne, 1)
C.Resize(, 3).Copy
.Cells(Ligne, 1).PasteSpecial xlPasteValues
C.Offset(, 5).Copy .Cells(Ligne, 4)
C.Offset(, 5).Copy
.Cells(Ligne, 4).PasteSpecial xlPasteValues
End With
End If
Next C
End With
End Sub

Quelqu'un à une idée ?
 

Pièces jointes

  • TESTFR2.xlsm
    305.8 KB · Affichages: 36
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Valoche54000,
Ce code mémorise et restitue d'éventuels commentaires en colonne G :
Code:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim d As Object, c As Range
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    '---mémorisation des commentaires en colonne G---
    Set d = CreateObject("Scripting.dictionary")
    For Each c In Sh.[G:G].SpecialCells(xlCellTypeConstants)
        d(c(1, -5).Value) = c
    Next
    Sh.Cells.Delete 'RAZ
    Intersect(.UsedRange.EntireRow, .[A:AI]).Copy Sh.[A1] 'copie tout le UsedRange
End With
Sh.UsedRange = Sh.UsedRange.Value 'supprime les formules
Sh.[A:G,N:AI].Delete 'pour alléger, reste 6 colonnes
If Sh.UsedRange.Row > 1 Then Sh.Rows("1:" & Sh.UsedRange.Row - 1).Delete 'facultatif
With Intersect(Sh.UsedRange.EntireRow, Sh.[G:G]) '7ème colonne auxiliaire
    .FormulaR1C1 = "=1/AND(RC2<>""" & Sh.Name & """,RC3<>""" & Sh.Name & """)"
    .Value = .Value 'supprime les formules
    .EntireRow.Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
    .ClearContents
End With
Sh.Columns("A:C").AutoFit 'ajustement largeur
Sh.Columns("D:E").Hidden = True 'masquage facultatif
Sh.Columns("F").ColumnWidth = 4
Application.Goto Sh.[A1], True 'cadrage
AllerRetour Sh
'---restitution des commentaires en colonne G---
For Each c In Sh.[A:A].SpecialCells(xlCellTypeConstants)
    If d.exists(c.Value) Then c(1, 7) = d(c.Value)
Next
Sh.[G:G].Font.Color = vbRed 'police rouge
End Sub
Chaque commentaire est repéré et restitué par la date en colonne A (normalement il n'y a pas plus d'une rencontre par jour).

Fichier (4).

A+
 

Pièces jointes

  • TESTFR2(4).xlsm
    199.3 KB · Affichages: 24

Valoche54000

XLDnaute Nouveau

Bien vu job75.

Serais-tu capable de me libérer les colonnes de G à l'infini?
 

job75

XLDnaute Barbatruc
Re,

Cela ne servirait à rien.

Dans les feuilles les commentaires sont forcément liés aux rencontres : si on supprime les rencontres dans la feuille "20172018" il faut que les commentaires disparaissent.

On pourrait les avoir dans plusieurs colonnes mais je n'en vois pas l'intérêt.

A+
 

Valoche54000

XLDnaute Nouveau

Donc je suis bloquée pour l'instant.
Je vais crééer un nouveau poste la suite de mon projet espérant que cela donnes des idées.
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…