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

V

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:
Trier par date Trier par votes
piga25

piga25

XLDnaute Barbatruc
Bonjour,
Vos cellules colorées sont issues d'une mise en forme conditionnelle qui elle donne le résultat (couleur jaune) en fonction de valeur (résultat du match).
Comme sur vos feuilles, il n'y a pas ces résultats, cela ne peut pas fonctionner.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Valoche54000, piga25,

Voyez le fichier joint et cette macro dans ThisWorkbook :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    Sh.Cells.Delete 'RAZ
    .[A:AI].Copy Sh.[A1] 'copie tout
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
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
    .ClearContents
End With
Application.Goto [A1], True 'cadrage
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub
Elle se déclenche quand on active une feuille.

PS1 : ne tripotez pas les MFC que j'ai proposées SVP, elles s'appliquent sur les colonnes entières...

PS2 : j'ai supprimé la liaison intempestive qui existait avec un fichier inexistant...

A+
 

Pièces jointes

  • TESTFR2(1).xlsm
    196.4 KB · Affichages: 28
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

La macro précédente crée un fort saut d'écran parce que les colonnes A:AI entières sont copiées.

Cette macro y remédie, seul le UsedRange est copié :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    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
    On Error Resume Next 'si aucune SpecialCell
    .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
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub
Fichier (2).

A+
 

Pièces jointes

  • TESTFR2(2).xlsm
    196.2 KB · Affichages: 22
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau
job75 à dit:
Re,

La macro précédente crée un fort saut d'écran parce que les colonnes A:AI entières sont copiées.

Cette macro y remédie, seul le UsedRange est copié :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
With Sheets("20172018") 'nom à adapter
    If Sh.Name = .Name Then Exit Sub
    Application.ScreenUpdating = False
    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
    On Error Resume Next 'si aucune SpecialCell
    .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
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub
Fichier (2).

A+
Cliquez pour agrandir...

Effectivement c'est au moins 2X plus rapide !

Par contre ce qui m’embête c'est la suite ....
 
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau
Nous avons divers onglets avec les noms des équipes associées.

Maintenant , en partant du fichier posté par job75 post #8 est-il possible de positionner à partir de G40 la selection B1,C1 et F1 ( match aller) et en G41 la selection B38,C38 et F38 ( match retour )
et de recommencer à partir de K40 la selection B2,C2 et F2 ( match aller) et en K41 la selection B20,C20 et F20 ( match retour )
et ainsi de suite.....

En image : https://www.cjoint.com/c/HHiuyZhKR3x
HHiuyZhKR3x


une idée, un miracle
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Je comprends ce que vous voulez mais la disposition n'est pas convenable.

Voyez plutôt ce fichier (3) et cette macro :
Code: 
Sub AllerRetour(Sh As Object)
Dim t, i&, j As Variant
Sh.UsedRange.Sort Sh.Cells(1), xlAscending, Header:=xlNo 'tri sur les dates
With Sh.UsedRange.Resize(, 7)
    .Columns(7) = "=B1&C1"
    t = .Value 'matrice, plus rapide
    For i = 1 To UBound(t)
        j = Application.Match(t(i, 3) & t(i, 2), .Columns(7), 0)
        If IsError(j) Then j = i
        t(i, 7) = IIf(j < i, j, i)
    Next
    .Columns(7) = Application.Index(t, , 7)
    .Sort .Columns(7), xlAscending, Header:=xlNo
    .Columns(8) = "=1/(G1=G2)"
    .Columns(8) = .Columns(8).Value 'supprime les formules
    .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Insert
End With
Sh.Columns("G:H").ClearContents 'RAZ des colonnes auxiliaires
End Sub
Bonne nuit.
 

Pièces jointes

  • TESTFR2(3).xlsm
    197.2 KB · Affichages: 26
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau
Bonsoir,

ne trouvant pas le sommeil, je me suis penchée sur mon souci et je pense avoir trouver une astuce mais il me faut votre retour:

Avec le fichier du post#7 de job75, il faudrait modifier le code car le code se déclenche quand on active une feuille en laissant d'éventuels commentaires dans les colonnes G ou H ou autres > la colonne F : ils disparaissent.

Le code devrait interagir avec les 6 premiéres colonnes de A à F et ne pas supprimer le contenu des autres colonnes >F

Si cela est possible , on copiera les 6 colonnes A:F en G:L et on pourra refaire une MFC.

Comme cette nouvelle MFC sera sur la feuille , la couleur de la cellule pourra être copier à volonté.

et ensuite on pourra traiter le post#9

Qu'en dites-vous faisable ?
 
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau
job75 à dit:
Re,

Je comprends ce que vous voulez mais la disposition n'est pas convenable.

Voyez plutôt ce fichier (3) et cette macro :
Code: 
Sub AllerRetour(Sh As Object)
Dim t, i&, j As Variant
Sh.UsedRange.Sort Sh.Cells(1), xlAscending, Header:=xlNo 'tri sur les dates
With Sh.UsedRange.Resize(, 7)
    .Columns(7) = "=B1&C1"
    t = .Value 'matrice, plus rapide
    For i = 1 To UBound(t)
        j = Application.Match(t(i, 3) & t(i, 2), .Columns(7), 0)
        If IsError(j) Then j = i
        t(i, 7) = IIf(j < i, j, i)
    Next
    .Columns(7) = Application.Index(t, , 7)
    .Sort .Columns(7), xlAscending, Header:=xlNo
    .Columns(8) = "=1/(G1=G2)"
    .Columns(8) = .Columns(8).Value 'supprime les formules
    .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Insert
End With
Sh.Columns("G:H").ClearContents 'RAZ des colonnes auxiliaires
End Sub
Bonne nuit.
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau

Effectivement,

l'idée de base est là, mais comme tu l'as dis la disposition a besoin d'être revue.

Par contre, ne peux pas empecher le reset complet de chaque feuille compléte mais de limiter aux 6 prémiéres colonnes.

Le fait d'avoir les cellules colorées sont cruciales pour la suite.

bonne nuit
 
Vote positif 0 Vote négatif
V

Valoche54000

XLDnaute Nouveau
Bonjour à tous,

Pas de réponses :( vers 14h donc je me suis dit que je n'aurait pas de retours positifs.

Donc de mon coté, j'ai fait autrement ce n'est pas propre mais cela fonctionne , certes c'est plus long ......

Il n'y a plus de MFC sur l'onglet de base.; une macro '' test '' envoie les noms d'équipes dans leurs onglets ( sans couleur ).
La macro '' MFC'' qui va mettre en surbrillance dans les colonnes B et C de chaque onglet.

Inconvénient:
Lors du transfert de datas dans chaque onglet, il ne faut être pas épileptique.
ensuite c'est long car je dois activer 20 fois la macro MFC pour chaque onglet.
C'est une solution de fortune , je vous l'accorde mais j'essaie de me débrouiller.
Si vous pouvez m'aider à rendre les macros plus propre je suis preneuse.

Pourrais-je avoir de l'aide pour le poste #9, svp ?
 

Pièces jointes

  • TEST2.xlsm
    209 KB · Affichages: 22
Vote positif 0 Vote négatif

Discussions similaires

Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
234
Zonmé
Z
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
152
rebatte
R
Y
  • Question
Microsoft 365 Insérer des lignes selon variable
Réponses
1
Affichages
225
gbinforme
G
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
147
souhaib ad
S
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
451
Phil69970
Phil69970
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
304
Usine à gaz
Usine à gaz
Y
  • Question
XL 2013 Macro positionnée dans le code d'un feuille
Réponses
10
Affichages
280
Dranreb
Dranreb
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
75
Latias
L
_l_ours
  • Résolu(e)
XL 2016 Macro Dim c As Range, i As Long
Réponses
8
Affichages
219
mapomme
mapomme
L
  • Question
XL 2016 correction d'un code VBA
Réponses
7
Affichages
306
LAPIN-53
L

Membres actuellement en ligne

3 membres et 47 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 165
Messages
2 085 882
Membres
103 010
dernier inscrit
Sys974