XL 2016 Procédure trop longue pour une macro existante

[ABDELHAK]

Bonjour à tous,

Je cherche de l’aide pour résoudre mon problème, s’il vous plaît.

J’ai déjà une macro que notre ami kingfadhel m’a réalisé. J’ai adapté celle-ci mais la procédure est visiblement trop longue.

Pouvez-vous m’aider à corriger le tir s’il vous plaît ?

J’ai un fichier de 2 feuilles


Dans la (feuille «1»), il y a un tableau (TAB_A) (B5 : LS867).

La 2ième colonne contient des références (A1, A2, A3, …, FZ2)

Il y a 330 autres colonnes et à chaque colonne correspond une date : (C5 : C867), (D5 : D867), (E5 : E867), (F5 : F867), …, (LS5 : LSA867).


Dans la (feuille «2»), il y a 320 tableaux. Les cellules ont comme données des chiffres de 1 à 100 dont 20 cellules ont un fond vert.

TAB_1 : (B4 : LS13)

Exemple :

La cellule B18 à un fond vert, je veux que la macro exécute un copier/coller vers la colonne C de TAB1 (feuille «1») soit la cellule D5. Elle doit garder son fond vert et remplacer la valeur de B18 par le chiffre 1.

Passer à TAB_2 (B18 : LS27)

Exemple :

La cellule B18 à un fond vert, je veux que la macro exécute un copier/coller vers la colonne D de TAB1 (feuille «1») soit la cellule D5. Elle doit garder son fond vert et remplacer la valeur de R4 par le chiffre 1.

TAB_3 (B32 : LS41)

Exemple :

La cellule B32 à un fond vert, je veux que la macro exécute un copier/coller vers la colonne E de TAB1 (feuille «1») soit la cellule E5. Elle doit garder son fond vert et remplacer la valeur de R4 par le chiffre 1.

Et ainsi de suite jusqu’au dernier tableau (soit 320 tableaux au total)

Merci d’avance pour votre aide.

 

[job75]

Bonjour ABDELHAK,

Vos explications sont quasiment incohérentes, je n'ai rien compris.

De toute façon dès le moment où une macro fait beaucoup de copier-coller c'est forcément long !!!

A+

 

[Simply]

Hi,

Ma perchè interviene il traduttore mentre scrivo?

limita il range alle sole celle utilizzate
Per l = 4 a 4255


Esaminare come leggere i dati non i colori
Se celle (l, c) .Interior.Color = RGB (0, 250, 0) Quindi

 

[youky(BJ)]

Bonjour à tous,
je pense avoir pigé!
A tester la macro est rapide car je teste par groupe de 10 et sort si vide
Bruno

 

[ABDELHAK]

Bonjour youki(BJ)?
Merci d'avoir répondu, hélas cela ne donne pas le résultat attendu.
Je suis conscient que mes explications ne soient pas claire.
Ceci explique cela.
A+

 

[ABDELHAK]

Bonjour ABDELHAK,

Vos explications sont quasiment incohérentes, je n'ai rien compris.

De toute façon dès le moment où une macro fait beaucoup de copier-coller c'est forcément long !!!

A+

 

[ABDELHAK]

Bonjour job75,

C'est toujours le même problème exposer clairement ce que l'on veut faire.
Ce n'est pas une tâche aisée.
Sachez que c'est agréable d'avoir une réponse de votre part.
Je n'oublie pas ce que vous avez déjà fait pour moi.
Amicalement vôtre

ABDELHAK

 

[youky(BJ)]

Essayer ceci
J'écris 1 au lieu de la valeur
Bruno

 

[ABDELHAK]

Essayer ceci
J'écris 1 au lieu de la valeur
Bruno

 

[ABDELHAK]

Bonjour youki(BJ),
Merci pour votre aide, la macro fonctionne très bien.
A l'exception d'un détail, les cellules qui sont copiées en Feuil(1) doivent aussi gardé leurs fonds verts.
Si cela ne vous dérange pas, voulez-vous apporter un ajout concernant le fond vert des cellules ?
Sinon tout fonctionne parfaitement.
Chapeau parce que j'étais sceptique par rapport aux explications pas très claires que j'ai envoyé au forum.
Mais apparemment vous avez très bien compris ce que je voulais, et c'est le principal.
Amicalement vôtre.

ABDELHAK

 

[youky(BJ)]

Bonjour,
Voici avec la couleur, j 'efface et enlève toutes les couleurs en début de macro . . .
Bruno
Code ou fichier

Sub youkybj()
Application.Calculation = xlCalculationManual
With Feuil1
.[C5:LJ4300].ClearContents 'efface
.[C5:LJ4300].Interior.Color = xlNone 'supp couleur
Set Sh = Feuil4
For lig = 4 To 4255 Step 14
j = j + 1
For col = 2 To 322
For k = 0 To lig + 8
If Sh.Cells(lig + k, col) = "" Then Exit For
If Sh.Cells(lig + k, col).Interior.Color = RGB(0, 250, 0) Then
lig1 = ((col - 2) * 10) + k + 5
.Cells(lig1, j + 2) = 1
.Cells(lig1, j + 2).Interior.Color = RGB(0, 250, 0)
End If
Next
Next
Next
.Select
End With
Application.Calculation = xlCalculationAutomatic
End Sub

 

[ABDELHAK]

Bonjour,
Voici avec la couleur, j 'efface et enlève toutes les couleurs en début de macro . . .
Bruno
Code ou fichier

Sub youkybj()
Application.Calculation = xlCalculationManual
With Feuil1
.[C5:LJ4300].ClearContents 'efface
.[C5:LJ4300].Interior.Color = xlNone 'supp couleur
Set Sh = Feuil4
For lig = 4 To 4255 Step 14
j = j + 1
For col = 2 To 322
For k = 0 To lig + 8
If Sh.Cells(lig + k, col) = "" Then Exit For
If Sh.Cells(lig + k, col).Interior.Color = RGB(0, 250, 0) Then
lig1 = ((col - 2) * 10) + k + 5
.Cells(lig1, j + 2) = 1
.Cells(lig1, j + 2).Interior.Color = RGB(0, 250, 0)
End If
Next
Next
Next
.Select
End With
Application.Calculation = xlCalculationAutomatic
End Sub

 

[ABDELHAK]

Bonjour youki(BJ),
J'étais déjà très content de la macro précédente fonctionnant avec ces milliers de lignes (procédure trop longue).
Mais vous, qui avec la macro d'une 20aines de lignes que vous avez eu l'amabilité de réaliser pour moi et avec le même résultat, avez tout bonnement cassé la baraque. C'est juste phénoménal.
Mille merci pour votre aide redoutablement efficace.
Amicalement vôtre.
ABDELHAK

 

[ChTi160]

Bonsoir ABDELHAK
Bonsoir le Fil (youky(BJ)),le Forum
Bien que youky(BJ) ait répondu a la demande .
Une question a quoi servent les lettres en Colonne "B" de la feuille "1" et celles présentent au niveau des Lignes "3,17,31 etc etc"de la feuille "2"
ainsi que les numéros présente sur le Lignes au dessus soit :"2,16,30 etc etc"
merci par avance
jean marie

 

[youky(BJ)]

Bonjour ChTi,
Pour répondre à ta question, en Feuil1 il y a A1 A2 A3 jusqu'à 10 ensuite B1 B2 . . . .
En feuil2 en col B on a la lettre A (en B3) les chiffres à gauche col A sont les N° plus on descend on incrémente A que l'on retrouve en Feuil1
Le but écrire en bonne place de feuil1 le chiffre 1 si la cellule est verte en feuil2.

Merci pour tes remerciements ABDELHAK,
J'avais fait une autre macro que je pensais plus performante et plus courte mais à priori c'est pareil, je la mets joint.
Bruno

Sub essai()
Application.Calculation = xlCalculationManual
Feuil1.[C5:LJ4300].ClearContents 'efface
Feuil1.[C5:LJ4300].Interior.Color = xlNone 'supp couleur
For lig = 4 To 4246 Step 14
j = j + 1
For Each c In Feuil4.Range("A" & lig & ":LJ" & lig + 9).SpecialCells(2)
If c.Interior.Color = RGB(0, 250, 0) Then
lig1 = ((c.Column - 2) * 10) + (c.Row - lig) + 5
Feuil1.Cells(lig1, j + 2) = 1
Feuil1.Cells(lig1, j + 2).Interior.Color = RGB(0, 250, 0)
End If
Next
Next
Feuil1.Select
Application.Calculation = xlCalculationAutomatic
End Sub