COPIER CELLULES EN MODIFIANT LA VALEUR DE CELLE-CI

[ABDELHAK]

Bonjour,

J’aimerais votre aide pour réaliser une nouvelle macro.

J’ai un fichier contenant 2 feuilles (Feuil4 et Feuil5).

Dans la Feuil4, il y a 1 tableau (TAB1) et dans la Feuil5, il y a 1 tableau (TAB2).

Je voudrais que la macro exécute des copier/coller des cellules à fond vert se trouvant dans (TAB1) de la Feuil4 vers (TAB2) de la Feuil5 en changeant la valeur des cellules par le chiffre « 1 ».

J’ai déjà une macro que notre ami job75 a réalisé pour moi et qui exécute quasi les mêmes tâches à un détail près.

J’ai essayé de l’adapter à mon nouveau fichier sans résultat. C’est très compliquer à faire.

La pièce jointe contient tous les détails, en espérant que vous comprendrez ce que je veux.

Merci d’avance.

ABDELHAK

 

[ABDELHAK]

Rebonjour le forum,

Permettez-moi d'insister pour sollicité votre aide. Cela fait +ieurs jours que j'attends.
Merci de bien vouloir répondre.

A+

 

[cathodique]

Bonjour,

Désolé ton fichier pose un gros problème de sécurité. Trop risqué de l'ouvrir.

 

[ABDELHAK]

Bonjour cathodique,

D'abord merci d'avoir répondu à ma demande.
Quant au fichier, j'ai l même problème quand je l'ouvre, mais je l'utilise malgré tout.
Si vous me dites que ce fichier pose des problèmes de sécurité, il va de soi que je n'ai aucunes intentions de vous posez des problèmes de quelques natures que se soient.
J'ai du respect pour tout ceux, chez excel download, qui au quotidien se donnent sans compter et qui m'ont déjà beaucoup apporté.
En un mot respect, je remettrai "le couvert" plus tard.
Encore 1000 merci pour tout.

Cordialement.

ABDELHAK

 

[job75]

Bonjour ABDELHAK, cathodique,

A priori le fichier ne présente pas de danger.

La macro à placer dans le code de "Feuil5" :

Private Sub Worksheet_Activate()
Dim dest As Range, source As Range, c As Range, x$, i As Variant
Application.ScreenUpdating = False
Set dest = Sheets("Feuil5").[B8:B1829] 'feuille et plage à adapter
dest.Clear: dest.Borders.Weight = xlThin 'RAZ
Set source = Sheets("Feuil4").[B9:IU18] 'feuille et plage à adapter
On Error Resume Next 'si la plage ne contient pas de nombre
For Each c In source.SpecialCells(xlCellTypeConstants, 1)
  If c.Interior.ColorIndex = 4 Then 'vert
    x = Cells(c.Row - source.Row + 1, c.Column - source.Column + 1).Address(0, 0)
    i = Application.Match(x, dest.Columns(0), 0)
    If IsNumeric(i) Then c.Copy dest(i): dest(i) = 1
  End If
Next
End Sub

A+

 

[ABDELHAK]

Bonjour job75,

Je vous remercie infiniment pour la enième macro que vous avez réalisé pour moi.
Je commençais à désespérer de ne pas avoir de réponse et voilà que ....
Vous n'imaginez pas à quelle cela me fait plaisir.
La macro fonctionne à merveille. En effet, il suffit d'appuyer sur la Feuil5 pour qu'elle s'exécute.
C'est juste bleufant, incroyable, etc.
Je vous suis sincèrement très reconnaissant.
Merci, merci et encore merci.

ABDELHAK

A+

 

[job75]

Re,

Je crois comprendre que vous aurez un bon nombre de feuilles sources, que vous nommerez probablement TAB1 TAB2 TAB3...

Alors le mieux est d'utiliser cette macro dans ThisWorkbook :

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Not Sh.Name Like "TAB#*" Then Exit Sub
Dim n%, dest As Range, source As Range, c As Range, x$, i As Variant
n = Val(Replace(Sh.Name, "TAB", ""))
Application.ScreenUpdating = False
Set dest = Sheets("Résultat").[A8:A1829].Offset(, n) 'feuille et plage à adapter
dest.Clear: dest.Borders.Weight = xlThin 'RAZ
Set source = Sh.[B9:IU18] 'plage à adapter
On Error Resume Next 'si la plage ne contient pas de nombre
For Each c In source.SpecialCells(xlCellTypeConstants, 1)
  If c.Interior.ColorIndex = 4 Then 'vert
    x = Cells(c.Row - source.Row + 1, c.Column - source.Column + 1).Address(0, 0)
    i = Application.Match(x, dest.Columns(1 - n), 0)
    If IsNumeric(i) Then c.Copy dest(i): dest(i) = 1
  End If
Next
End Sub

Elle ne traite qu'une feuille source donc elle prend moins de temps qu'une macro qui devrait traiter toutes les feuilles.

Fichier (2).

A+

 

[job75]

Bonjour ABDELHAK, le forum,

Le copier-coller prend beaucoup de temps, s'il n'y a que la couleur à appliquer ceci est bien plus rapide :

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim n%, dest As Range, source As Range, c As Range, x$, i As Variant
n = Val(Mid(Sh.Name, 4))
If n = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules
Set dest = Sheets("Résultat").[A8:A1829].Offset(, n) 'feuille et plage à adapter
dest = "": dest.Interior.ColorIndex = xlNone 'RAZ
Set source = Sh.[B9:IU18] 'plage à adapter
On Error Resume Next 'si la plage ne contient pas de nombre
For Each c In source.SpecialCells(xlCellTypeConstants, 1)
  If c.Interior.ColorIndex = 4 Then 'vert
    x = Cells(c.Row - source.Row + 1, c.Column - source.Column + 1).Address(0, 0)
    i = Application.Match(x, dest.Columns(1 - n), 0)
    If IsNumeric(i) Then dest(i).Interior.ColorIndex = 4: dest(i) = 1
  End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Fichier (3).

Edit : pour ceux dont l'antivirus détectait un danger à l'ouverture j'ai reconstruit le fichier...

Bonne journée.

 

[ABDELHAK]

Bonjour job75,

Le dernier fichier que vous m'avez envoyé est super et vous avez bien deviné "la suite" à la seule différence que tous les "TAB" au nombre de 27 se trouvent Feuil4
Si vous voulez bien regarder, je joins le fichier avec toutes les références.
Dans tous les cas, merci.
Et bravo pour ce que vous faites.
A+
ABDELHAK

 

[job75]

Re,

Avec tous les tableaux dans une même feuille il faut une Worksheet_Activate :

Private Sub Worksheet_Activate()
Dim dest As Range, c As Range, n%, source As Range, c1 As Range, x$, i As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules
On Error Resume Next 's'il n'y a pas de SpecialCells
Set dest = [B8:AB1829] 'plage à adapter
dest = "": dest.Interior.ColorIndex = xlNone 'RAZ
For Each c In Sheets("TAB").[B:B].SpecialCells(xlCellTypeConstants, 2) 'feuille et colonne à adapter
  If c Like "TAB#*" Then
    n = Val(Mid(c, 4))
    Set source = c(5).Resize(10, 254) 'adapter éventuellement
    For Each c1 In source.SpecialCells(xlCellTypeConstants, 1)
      If c1.Interior.ColorIndex = 4 Then 'vert
        x = Cells(c1.Row - source.Row + 1, c1.Column - source.Column + 1).Address(0, 0)
        i = Application.Match(x, dest.Columns(0), 0)
        If IsNumeric(i) Then dest(i, n).Interior.ColorIndex = 4: dest(i, n) = 1
      End If
    Next c1
  End If
Next c
Application.Calculation = xlCalculationAutomatic
End Sub

Fichier (4).

Chez moi sur Win 10 - Excel 2013 il faut 0,4 seconde pour traiter les 1620 cellules colorées.

Avec des copier-coller il faudrait 6,2 secondes.

A+