Transferer des lignes vers d'autres onglets

Bonjour,

Je ne connais pas du tout le VBA, ce qui me pose quelques problèmes d'adaptations … J'ai pourtant vu des exemples dans le forum mais je n'arrive pas à les modifier ….

Voilà,

J'ai une feuille "Catalogue" elle contient un nombre aléatoire de ligne et plusieurs colonnes (normalement le nombre de colonne reste fixe)

Ce catalogue est une liste de composant électronique trié par un "code article".

Les lignes sont triées par "code article" car il peut y avoir plusieurs lignes avec le même code. (Un composant peut exister avec 2 ou plus fabricants différents)

Un ensemble de "code article" forme une carte électronique …

Un code article se retrouve souvent dans plusieurs cartes électroniques

Une colonne indique la ou les cartes ou est utilisé le code article

Ce que je cherche à faire

Je souhaite créer autant d'onglet que de cartes électroniques et dans chaque onglet retrouver uniquement les lignes contenant les codes articles utilisés sur la carte.

Je sais que je vais être embêté pour gérer les lignes en doublons car mon but est de faire des indicateurs pour chaque carte mais chaque chose en son temps

Merci pour l'aide que vous pourriez m'apporter

Voici une version allegé du fichier :

Cordialement,

Bonjour

une proposition avec une macro, à tester sur une copie de ton classeur

Sub gencarte()
Dim cartes As Variant
Application.ScreenUpdating = False
Set wss = Worksheets("Catalogue")
dl = wss.Range("A" & wss.Rows.Count).End(xlUp).Row
For i = 2 To dl
 cartes = split(wss.Cells(i, "J"), " ")
 For j = LBound(cartes, 1) To UBound(cartes, 1)
  If cartes(j) <> "" Then
   On Error GoTo terreur
   ongletexiste = True
   Set wsc = Worksheets(cartes(j))
   On Error GoTo 0
   If Not ongletexiste Then
    Set wsc = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    wsc.Name = cartes(j)
    wss.Rows(1).Copy wsc.Range("A1")
   End If
   dlc = wsc.Range("A" & wsc.Rows.Count).End(xlUp).Row + 1
   wss.Rows(i).Copy wsc.Range("A" & dlc)
   wsc.Range("J" & dlc) = cartes(j)
  End If
 Next j
Next i
Set wss = Nothing
Set wsc = Nothing
Application.ScreenUpdating = True
Exit Sub
terreur:
 ongletexiste = False
 Resume Next
End Sub

C'est Génial !!!!!

je vais essayer de faire ca sur mon fichier total car il fait plus de 1500 lignes, j'ai un peu peur du resultat, on verra si Excel arrivent a calculer ....

J'ai pas tout regardé mais pour l'instant ca correspond à ce que je voulais faire ...

Je vais étudier tout ça

Merci pour cette réponse aussi rapide

Cordialement,

Bonjour,

il y a quelques onglets parasites mais je suis en train de regarder pourquoi (il interprete mal le code de la carte à cause des zeros à la fin je crois) ..... ensuite je pense qu'il me faudra ajouter une condition pour verifier si le code article existe déjà dans l'onglet de destination mais je souhaite faire un comparatif avec une donnée d'une des colonnes pour savoir quels lignes choisir .....

Je vais essayer ce week end

En tout cas merci

Cordialement,

bonjour,

code adapté pour supprimer les doublons sur base du numéro d'article.

par contre, je n'ai pas pu tester l'autre problème, car je ne pense pas que les données qui le provoque soient présentes dans le fichier exemple que tu as fourni.

Sub gencarte()
Dim cartes As Variant
Application.ScreenUpdating = False
Set wss = Worksheets("Catalogue")
dl = wss.Range("A" & wss.Rows.Count).End(xlUp).Row
For i = 2 To dl
 cartes = Split(wss.Cells(i, "J"), " ")
 For j = LBound(cartes, 1) To UBound(cartes, 1)
  If cartes(j) <> "" Then
   On Error GoTo terreur
   ongletexiste = True
   Set wsc = Worksheets(cartes(j))
   On Error GoTo 0
   If Not ongletexiste Then
    Set wsc = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    wsc.Name = cartes(j)
    wss.Rows(1).Copy wsc.Range("A1")
   End If
   dlc = wsc.Range("A" & wsc.Rows.Count).End(xlUp).Row + 1
   Set rc = wsc.Range("A1:A" & dlc - 1).Find(wss.Range("a" & i))
   If rc Is Nothing Then
    wss.Rows(i).Copy wsc.Range("A" & dlc)
    wsc.Range("J" & dlc) = cartes(j)
   End If
  End If
 Next j
Next i
Set wss = Nothing
Set wsc = Nothing
Application.ScreenUpdating = True
Exit Sub
terreur:
 ongletexiste = False
 Resume Next
End Sub

Bonjour,

Effectivement, le problème n'était pas presenté dans le fichier

J'ai un logiciel qui me génère mon fichier .CVS et quand je l'ouvre avec Excel, les zéros devant et derrière mes références sont tronqués

exemple 023.1500 --> 23.15

Je ne sais pas si c'est du à Excel ou à mon logiciel (je n'ai pas accès à un paramètrage du fichier exporté), il foudrait qu'il interprete les cellules comme du texte et pas des nombres ...

ensuite, les cartes sont séparés par 2 espaces donc j'ai ajouté un espace et cela me donne les bons onglets ....

Revenons sur les doublons ... Merci pour cette version simplifié et surtout fonctionnel

j'essaye d'ajouter 2 comparaisons

l'une par rapport à la colonne R (statut)

l'une par rapport à la colonne M (intitulé Rohs),

Mon but étant que dans l'onglet de destination il me place le composant qui est Actif et Rohs avec pour référence la 1ère ligne copiée ... c'est à dire quil ne remplace la 1ère ligne copié que si la nouvelle est mieux ....

J'ai essayé de le faire avec le Rohs mais je ne peux même pas lancer la macro ....

j'ai pourtant déclaré les 2 variables au début en tant que texte (String)

If rc Is Nothing Then

wss.Rows(i).Copy wsc.Range("A" & dlc)

wsc.Range("J" & dlc) = cartes(j)

Else

rohscatalogue = wss.Cells(i, "M").Copy

If rohscatalogue Is "Oui" Then

rohscarte = wsc.Range("A1:A" & dlc - 1).Find(wss.Range("a" & i)).Copy(wss.Cells(i, "M"))

If rohscarte Is "Non" Or "" Then

wss.Rows(i).Copy wsc.Range("A" & dlc)

wsc.Range("J" & dlc) = cartes(j)

End If

End If

End If

Je pense que je copie mal le contenu de la cellule donc il n'arrive pas à faire la comparaison ...

j'ai egalement pensé à une fonction comparaison mais je n'en trouve pas ce qui m'étonne un peu .....

Cordialement,

Bonsoir,

code adapté, à vérifier

Sub gencarte()
Dim cartes As Variant
' pas de mise à jour de l'écran pendant l'éxecutiond de la macro
Application.ScreenUpdating = False
' wss permet d'adresser des éléments de la feuille catalogue
Set wss = Worksheets("Catalogue")
' dl dernière ligne du catalogue
dl = wss.Range("A" & wss.Rows.Count).End(xlUp).Row
' on parcourt toutes les lignes du catalogue en commencant à la ligne 2 (on ne prend pas la ligne titre)
For i = 2 To dl
 ' on éclate le champ cartes dans le tableau cartes
 cartes = Split(wss.Cells(i, "J"), " ")
  ' pour chacune des cartes trouvées
 For j = LBound(cartes, 1) To UBound(cartes, 1)
  If cartes(j) <> "" Then
  ' on arme le traitement d'erreur
   On Error GoTo terreur
   ' on fait l'hypothèse que l'onglet pour la carte existe déja
   ongletexiste = True
   ' wsc permet d'adresser les objets sur la feuille de la carte en cours
   ' si l'onglet n'existe pas, il y aura un traiteùent d'erreur ou la variable ongletexiste sera mise = false
   Set wsc = Worksheets(cartes(j))
   ' on reactive la gestion standard des erreurs
   On Error GoTo 0
   If Not ongletexiste Then
    'on ajoute une feuille pour la carte à la suite de toutes les feuilles du classeur
    Set wsc = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    'on nomme la feuille d'après le nom de la carte
    wsc.Name = cartes(j)
    ' on copie la ligne titre
    wss.Rows(1).Copy wsc.Range("A1")
   End If
   ' dlc est la première ligne libre dans l'onglet de la carte
   dlc = wsc.Range("A" & wsc.Rows.Count).End(xlUp).Row + 1
   ' on vérifie si le produit se trouve déja dans la feuille de la carte, rc contient la référence de la ligne trouvée)
   Set rc = wsc.Range("A1:A" & dlc - 1).Find(wss.Range("a" & i), lookat:=xlWhole)
   ' on ne l'a pas trouvé
   If rc Is Nothing Then
    ' on copie la ligne du catalogue
    wss.Rows(i).Copy wsc.Range("A" & dlc)
    ' on adapte la carte
    wsc.Range("J" & dlc) = cartes(j)
   Else
    ' on l'a trouvé, on vérifie si on n'a pas mieux (homologuation et Rohs
    If wsc.Range("L" & i) = "Oui" And wss.Range("L" & rc.Row) <> "Oui" Or _
       wsc.Range("M" & i) = "Oui" And wss.Range("M" & rc.Row) <> "Oui" Then
       ' on a trouvé mieux , on copie la ligne du catalogue
       wss.Rows(i).Copy wsc.Range("A" & rc.Row)
       ' on adapte la carte
       wsc.Range("J" & rc.Row) = cartes(j)
    End If
   End If
  End If
  ' carte suivante
 Next j
' ligne suivante sur le catalogue
Next i
Set wss = Nothing
Set wsc = Nothing
Application.ScreenUpdating = True
Exit Sub
terreur:
 ongletexiste = False
 Resume Next
End Sub

Bonjour,

Il y avait une petite inversion sur la phrase

"If wsc.Range("L" & i) = "Oui" And wss.Range("L" & rc.Row) <> "Oui" Or _

wsc.Range("M" & i) = "Oui" And wss.Range("M" & rc.Row) <> "Oui" Then"

mais cela ne m'a pas empeché de continuer et pouvoir faire tout ce que je voulais

Encore merci pour votre aide.... Je commence à prendre gout à VBA, j'en reviens pas a quel point c'est puissant