Aide pour macro

[didcha]

Bonjour à tous,
je suis certain que quelqu'un pourra m'aider et merci d'avance
j'ai un fichier , dans ce fichier la colonne B, de (B1:B20) contient des valeurs ex:F33345 sur 20 lignes
de (B21:B40) la 21 lignes change et contient ex:F33346 etc
ce que je voudrais c'est trouver une macro qui lorsque la valeur change par ex ici a B21 donner l'instruction que je veux genre copier tout les champs concernant le F33345
donc faire un balayage complet de la colonne B car elle n'est pas fige et d'autre numéro vont s'ajouter
j'espère avoir été clair
merci à vous

 

[jp14]

Re : Aide pour macro

Bonsoir et bienvenue sur le forum

Ci joint le fichier avec une macro à tester

Deux variables publiques permettent de mémoriser le contenu de la cellule et l'adresse quand on la sélectionne.
Quand on change le contenu de la cellule la procédure "Private Sub Worksheet_Change(ByVal Target As Range)" permet de changer le contenu des cellules ayant la même valeur.
Un drapeau (flag) permet d'éviter la réentrance.

JP

 

[didcha]

Re : Aide pour macro

Tout d'abord merci à toi pour ce boulot
j'ai remis un nouveau fichier excel pour mieux exprimer mon besoin

thanks

 

[jp14]

Re : Aide pour macro

Bonjour

Ci joint le fichier avec un userform pour sélectionner le code à remplacer ainsi que le nouveau code.

A tester

JP

 

[didcha]

Re : Aide pour macro

RE,

Je t'ai mis un bouton qui montre le resultat escompté
merci à toi

 

[jp14]

Re : Aide pour macro

Bonsoir

Ci dessous une procédure qui recopie les données des colonnes A et B dans les colonnes suivantes, en séparant les codes fournisseurs.
Il n'est pas nécessaire que les données de départ soient triées.

Option Explicit
Sub travdem()
Dim Nomfeuille1 As String
Dim coll As New Collection

Dim i As Byte
Dim item As Variant
i = 3 ' premier numéro de la colonne de destination
Nomfeuille1 = "Feuil3"

With Sheets(Nomfeuille1)
Call rempcollec("b", 2, Nomfeuille1, coll)

For Each item In coll
    Call copie(Nomfeuille1, CStr(item), i)
    i = i + 3
Next item

End With
End Sub
Private Sub copie(Nomfeuille1 As String, valeur1 As String, coldest As Byte)
Dim Cellule As Range
Dim Dl1 As Long
With Sheets(Nomfeuille1)
.Cells(1, coldest) = "Fournisseur"
.Cells(1, coldest + 1) = "Code Fournisseur"
For Each Cellule In .Range("b2:b" & .Range("b" & .Rows.Count).End(xlUp).Row)
    If Cellule = valeur1 Then
    Dl1 = .Cells(Columns(coldest).Cells.Count, coldest).End(xlUp).Row + 1
    .Cells(Dl1, coldest) = Cellule.Offset(0, -1)
    .Cells(Dl1, coldest + 1) = Cellule
    End If
Next Cellule

End With
End Sub
'


Private Sub rempcollec(Colonnenom As String, £lignedep As Long, £nomf As String, coll As Collection)
Dim £cel As Range
Dim £plage As Range
Dim Dl1 As Long
Dim £data As String
With Worksheets(£nomf)
    Set £plage = .Range(Colonnenom & £lignedep & ":" & Colonnenom & .Range(Colonnenom & .Rows.Count).End(xlUp).Row)
End With
For Each £cel In £plage
    £data = Trim(£cel)
    On Error Resume Next
    coll.Add £data, CStr(£data)
Next £cel
On Error GoTo 0
End Sub

JP

 

[didcha]

Re : Aide pour macro

RE à toi

j'ai essayé ton code mais ca bug lol

alors je t'envoie le fichier sur lequel je bosse
j'ai fais mes extraction de fournisseur et mes questions sont sur le fichier

merci encore
Didier

 

[jp14]

Re : Aide pour macro

Bonjour

Ci dessous le code pour créer l'onglet si nécessaire et copier les données dans l'onglet concerné.

Option Explicit

' programme principal
Sub travdem()
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim coll As New Collection
' pour boucler sur la colonne 1
Dim item As Variant
Nomfeuille1 = "Portefeuille"

With Sheets(Nomfeuille1)
Call rempcollec("b", 2, Nomfeuille1, coll)

For Each item In coll
    If onglet(CStr(item)) = False Then Call copie(Nomfeuille1, CStr(item), 1, CStr(item))
Next item

End With
End Sub

' programme de copie à modifier si on désire faire des ajouts
Private Sub copie(Nomfeuille1 As String, valeur1 As String, coldest As Byte, Nomfeuilledest As String)
Dim Cellule As Range
Dim Dl1 As Long
With Sheets(Nomfeuilledest)
.Cells(1, coldest) = "Fournisseur"
.Cells(1, coldest + 1) = "Code Fournisseur"
For Each Cellule In Sheets(Nomfeuille1).Range("b2:b" & Sheets(Nomfeuille1).Range("b" & Sheets(Nomfeuille1).Rows.Count).End(xlUp).Row)
    If Cellule = valeur1 Then
    Dl1 = .Cells(Columns(coldest).Cells.Count, coldest).End(xlUp).Row + 1
    .Cells(Dl1, coldest) = Cellule.Offset(0, -1)
    .Cells(Dl1, coldest + 1) = Cellule
    End If
Next Cellule

End With
End Sub
'

' recherche des différents code fournisseur
Private Sub rempcollec(Colonnenom As String, £lignedep As Long, £nomf As String, coll As Collection)
Dim £cel As Range
Dim £plage As Range
Dim Dl1 As Long
Dim £data As String
With Worksheets(£nomf)
    Set £plage = .Range(Colonnenom & £lignedep & ":" & Colonnenom & .Range(Colonnenom & .Rows.Count).End(xlUp).Row)
End With
For Each £cel In £plage
    £data = Trim(£cel)
    On Error Resume Next
    coll.Add £data, CStr(£data)
Next £cel
On Error GoTo 0
End Sub

' fonction qui retourne "True" si l'onglet n'existe pas 
Private Function onglet(name1 As String) As Boolean
Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = name1 Then Exit Function
    Next Sh
   Select Case MsgBox("Voulez vous créer la feuille avec le code fournisseur : " & name1,  vbYesNo Or vbQuestion Or vbDefaultButton1, "Création")
   
    Case vbYes
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = name1  
    Case vbNo
        onglet = True
        Exit Function
   End Select
End Function

A tester

JP

 

[didcha]

Re : Aide pour macro

Bonjour
Merci pour ton code, mais j'ai des problèmes pour le faire fonctionner
j'ai essayer de le mettre dans une macro "module" mais ça bloque
en fait si tu pouvais me l'integrer dans un module qvec un bouton macro
sinon t'embete pas trop non plus

a plus et merci

 

[jp14]

Re : Aide pour macro

Bonsoir

Ci joint le fichier avec la macro

A tester

JP