2 petites Macros à modifier...SVP

[Christian0258]

Bonjour à tout le forum,

Je souhaiterais votre aide afin de modifier 2 macros.

Je joins le fichier, les explications sont dessus...

Je vous remercie pour le temps que vous voudrez bien m'accorder.

Bien amicalement,
Christian

 

[Pierrot93]

Re : 2 petites Macros à modifier...SVP

Bonjour Christian

tu devrais avertir que ta macro modifies les barres d'outils de celui qui la lancera... perso aime pas trop...

bonne journée
@+

 

[Christian0258]

Re : 2 petites Macros à modifier...SVP

Re, le forum,

Mes excuses, Pierrot, pour la macro barre d'outils, je l'ai supprimé (sur le nouveau fichier).
Merci Jean-Pierre, pour ton aide, mais la macro "Supp virgules" fonctionne pour tous les articles de la colonne F mais je voudrais exclure de ce traitement les articles référencés dans le tableau bleu"produits".

à+
Christian

 

[Christian0258]

Re : 2 petites Macros à modifier...SVP

Re, Jean-Marcel, le forum,

Mes excuses, pour le mauvais prénom, Jean-Marcel

(et non Jean-Pierre)

à+
Christian

 

[Pierrot93]

Re : 2 petites Macros à modifier...SVP

Re, bonjour Jean-Marcel

Merci Christian d'avoir modifié ton fichier.

Regarde le code ci dessous si il te convient :

Sub suppvirgule()
Dim x As Range, y As Range, b As Boolean
For Each x In Range("F2:F" & Range("F65536").End(xlUp).Row)
    b = False
    For Each y In Range("G4:G" & Range("G65536").End(xlUp).Row)
        If x.Value = y.Value Then b = True
    Next y
    If b = False Then x.Replace What:=",*", Replacement:="  "
Next x
End Sub

@+

 

[Bebere]

Re : 2 petites Macros à modifier...SVP

bonjour Christian,Jean-Marcel,Pierrot
une autre proposition
à bientôt

 

[Paritec]

Re : 2 petites Macros à modifier...SVP

Bonjour Jean Marcel, Pierrot, christian
Pierrot je n'arrive pas à me faire à ton b et pourtant tu l'utilises tout le temps et c'est pratique
mais il faut que j'essaye( que j'y pense surtout )
a+
Papou

 

[Christian0258]

Re : 2 petites Macros à modifier...SVP

Re, le forum, Pierrot93,

Je te remercie,Pierrot, ta macro est impec de chez impec.

Dis-moi peux-tu regarder : pour la macro copier, Jean-Marcel (que je remercie) à réglé le problème pour que la copie se fasse à droite de la feuille "Récaps" mais il reste le fait que cette copie n'ajuste pas la largeur automatique des colonnes.

Encor merci pour votre aide.

à+
Christian

 

[Christian0258]

Re : 2 petites Macros à modifier...SVP

Re,

merci à vous tous,

c'est impec.

Bien à vous.

Christian

 

[skoobi]

Re : 2 petites Macros à modifier...SVP

Bonjour tout le monde,

avec un peu de retard, mes neurones tournent aux ralentis car je suis refroidis , une autre approche en utilisant Find, plus rapide que de boucler ligne par ligne:

Sub suppvirgule()
  Dim Trouve As Range, FirstAddress As String, AncLig As String
  'on cherche en colonne F la première virgule
  With Columns("F:F")
    Set Trouve = .Find(",", LookIn:=xlValues, LookAt:=xlPart)
    If Not Trouve Is Nothing Then
    'on identifie la première adresse
      FirstAddress = Trouve.Address
      Do
      'si la cellule actuelle ne se trouve pas dans la liste d'exception
        If Range("G4", [G65536].End(xlUp)).Find(Trouve.Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
          Trouve.Value = Replace(Trouve.Value, ",", "  ")
        End If
        'on garde la ligne de la cellule actuelle
        AncLig = Trouve.Row
        Set Trouve = .Find(",", after:=Trouve, LookIn:=xlValues, LookAt:=xlPart)
        'on boucle tant que l'adresse de la nouvelle est différente de la première
        'ET tant que la recherche suivante ce fait vers le bas (pour éviter de boucler sans fin sur les exceptions)
      Loop While Not Trouve Is Nothing And Trouve.Address <> FirstAddress And Trouve.Row > AncLig
    End If
  End With

End Sub

 

[Pierrot93]

Re : 2 petites Macros à modifier...SVP

Re

avec un tableu virtuel cela devrait être plus rapide :

Sub suppvirgule2()
Dim t1() As Variant, t2() As Variant, i As Integer, j As Integer, b As Boolean
t1 = Range("F2:F" & Range("F65536").End(xlUp).Row).Value
t2 = Range("G4:G" & Range("G65536").End(xlUp).Row).Value
For i = LBound(t1, 1) To UBound(t1, 1)
    b = False
    For j = LBound(t2, 1) To UBound(t2, 1)
        If t1(i, 1) = t2(j, 1) Then b = True
    Next j
    If b = False Then t1(i, 1) = Replace(t1(i, 1), ",", "  ")
Next i
Range("F2:F" & UBound(t1, 1) + 1).Value = t1
End Sub

@+

Edition : Aarf bonjour Skoobi, avais pas raffraichi...