Macro avec une fonction si avec plusieurs réponses

[Ophé]

Bonjour le forum,

je viens encore une fois pour une mission "macro" !!
Cette macro est peut-être simple, mais je bloque principalement que une création de ligne.

Je m'explique :

J'ai en colonne A des noms de techniciens en initiales (3lettres), si il y a plusieurs techniciens, un signe "+" les sépare.
Le but de la macro est :
Si il y a un plus dans la cellule A toute la ligne est copiée une fois, on divise les chiffres dans les colonnes S et T; et on supprime l'un des noms pour l'écrire en colonne X.
Idem s'il y a deux + (donc 3techniciens) mais on copie 2 fois la ligne et on divise par 3.

Je joins deux fichiers qui définissent plus clairement ce que je voudrais faire; j'ai mis des explications plus "claires" dessus.

Merci d'avance, même si ce n'est pas évident, pour moi en tout cas.

Ophé

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

bonjour Ophé,

voici une macro à tester :

Sub test()
Dim tabStr() As String, iStr As Integer, i As Integer, memValueS As Double, memValueT As Double
With ThisWorkbook.Sheets("base montage")
    For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
        tabStr = Split(.Range("A" & i).Text, "+")
        memValueS = .Range("S" & i).Value
        memValueT = .Range("T" & i).Value
        For iStr = 1 To UBound(tabStr)
            .Rows(i + 1).Insert
            .Rows(i).Copy .Rows(i + 1)
        Next iStr
        For iStr = LBound(tabStr) To UBound(tabStr)
            .Range("X" & i).Offset(iStr, 0).Value = tabStr(iStr)
            .Range("S" & i).Offset(iStr, 0).Value = memValueS / (UBound(tabStr) + 1)
            .Range("T" & i).Offset(iStr, 0).Value = memValueT / (UBound(tabStr) + 1)
        Next iStr
    Next i
End With
End Sub

a+

 

[Ophé]

Re : Macro avec une fonction si avec plusieurs réponses

Bonjour mromain, le forum,

Merci beaucoup te t'occuper de mon "cas" !! Cette macro me convient, il y a juste 2, 3 détails qui me posent problème :

-lorsqu'il y a seulement 3 caractères, c'est à dire un seul technicien, rien ne doit se passer, donc (si c'est possible) il ne faut rien écrire dans la colonne X.
-pour les cellules en A où il y a plus d'un technicien c'est à dire 7 ou 11 caractères, les copier coller et les divisions sont parfaites, je voudrais seulement qu'il ne reste plus que 3 caractères dans la cellule A, ceux qui ne sont pas dans la colonne X : par exemple si a la base on a MCA+YLA+OPA, dans col A je voudrais : MCA et col X : YLA+OPA
dans la 2eme ligne identique : col A : OPA et col X : MCA+YLA
dans la 3ème ligne identique : col A : YLA et col X : MCA+OPA

Comme j'ai tenté de l'expliquer dans mon fichier.
Est-ce possible de rajouter cela au code??

Merci d'avance.

Ophé

 

[Ophé]

Re : Macro avec une fonction si avec plusieurs réponses

Re,

aussi, sur mon fichier global, la macro ne ouvre juste les lignes, elle ne copie pas les données et donc ne divise pas??

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

bonjour Ophé,

teste avec cette macro :

Sub test()
Dim tabStr() As String, iStr As Integer, i As Integer, memValueS As Double, memValueT As Double, jStr As Integer, strColX As String
With ThisWorkbook.Sheets("base montage")
    For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
        tabStr = Split(.Range("A" & i).Text, "+")
        memValueS = .Range("S" & i).Value
        memValueT = .Range("T" & i).Value
        For iStr = 1 To UBound(tabStr)
            .Rows(i + 1).Insert
            .Rows(i).Copy .Rows(i + 1)
        Next iStr
        For iStr = UBound(tabStr) To LBound(tabStr) Step -1
            If LBound(tabStr) <> UBound(tabStr) Then
                strColX = vbNullString
                For jStr = LBound(tabStr) To UBound(tabStr)
                    If jStr <> iStr Then
                        strColX = strColX & IIf(strColX = vbNullString, vbNullString, "+") & tabStr(jStr)
                    End If
                Next jStr
                .Range("X" & i).Offset(iStr, 0).Value = strColX
                .Range("A" & i).Offset(iStr, 0).Value = tabStr(iStr)
                .Range("S" & i).Offset(iStr, 0).Value = memValueS / (UBound(tabStr) + 1)
                .Range("T" & i).Offset(iStr, 0).Value = memValueT / (UBound(tabStr) + 1)
            End If
        Next iStr
    Next i
End With
End Sub

a+

 

[Ophé]

Re : Macro avec une fonction si avec plusieurs réponses

Bonjour,

merci encore, cette macro a fonctionné sur le fichier test même s'il subsiste un problème :
-lorsqu'il y a seulement 3 caractères, c'est à dire un seul technicien, rien ne doit se passer, donc (si c'est possible) il ne faut rien écrire dans la colonne X.

Et lorsque j'essaie sur un autre fichier ça ne fonctionne pas.

Je vous joins un autre fichier car je ne comprend pas.

Merci d'avance

Cdlt

Ophé

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

re,

sur l'exemple fourni, je n'ai pas réussi à voir ton problème (même en rajoutant une ligne avec "que 3 caractères"), ou alors, je ne l'ai pas compris .

a+

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

re,

peux-tu me faire un autre exemple avec une feuille contenant les "données sources", une feuille contenant les données traitées par la macro et une feuille contenant le résultat souhaité.
merki

a+

 

[Gruick]

Re : Macro avec une fonction si avec plusieurs réponses

Bonjour Ophé, Romain

Essayes ce code bien bête, mais qui fait tout ce que tu voulais.
Avant, prends soin d'effacer les explications en dessous de la dernière ligne de données.

Sub Ophé()
' Ophé Macro
' Macro enregistrée le 8/06/2009 par Gruick
i = 2
re:
If i >= Cells(2 ^ 16, 1).End(xlUp).Row Then Exit Sub
  If Len(Cells(i, 1)) = 3 Then i = i + 1
  If Len(Cells(i, 1)) = 7 Then 'inserer 1 ligne
    Cells(i + 1, 1).EntireRow.Insert
    Rows(i).Copy Destination:=Rows(i + 1)
    Cells(i, 1) = Left(Cells(i, 1), 3)
    Cells(i + 1, 1) = Right(Cells(i + 1, 1), 3)
    Cells(i, 19) = Cells(i, 19) / 2: Cells(i + 1, 19) = Cells(i, 19)
    Cells(i, 20) = Cells(i, 20) / 2: Cells(i + 1, 20) = Cells(i, 20)
    i = i + 1
  ElseIf Len(Cells(i, 1)) = 11 Then 'inserer 2 lignes
    Cells(i + 1, 1).EntireRow.Insert
    Cells(i + 1, 1).EntireRow.Insert
    Rows(i).Copy Destination:=Rows(i + 1)
    Rows(i).Copy Destination:=Rows(i + 2)
    Cells(i, 1) = Left(Cells(i, 1), 3)
    Cells(i + 1, 1) = Mid(Cells(i + 1, 1), 5, 3)
    Cells(i + 2, 1) = Right(Cells(i + 2, 1), 3)
    Cells(i, 19) = Cells(i, 19) / 3: Cells(i + 1, 19) = Cells(i, 19): Cells(i + 2, 19) = Cells(i, 19)
    Cells(i, 20) = Cells(i, 20) / 3: Cells(i + 1, 20) = Cells(i, 20): Cells(i + 2, 20) = Cells(i, 20)
    i = i + 2
  End If
GoTo re
End Sub

Hamlet euh... Gruick.

 

[Ophé]

Re : Macro avec une fonction si avec plusieurs réponses

Bonjour mromain, Gruick,

je vais joindre mes fichiers avec ce qui a été modifié dans mon fichier de fin en couleur mais je ne vois pas comment faire plus clair.

Ton code fonctionne en effet Gruick mais lorsqu'il y a 3 caractères (exemple : LAN) je voudrais que "LAN" ne s'affiche pas en colonne X. Est ce possible?
Sinon elle a très bien fonctionner au début sur mon fichier principal, mais à un moment j'ai eu un beug sur ce passage "If Len(Cells(i, 1)) = 7 Then 'inserer 1 ligne"

Ce que je ne comprend pas, car même si je ne suis pas très douée en VBA, apparament ça fait une boucle quand pour passer à la deuxieme ligne.

Avant d'effectuer cette macro, je reduis les noms des techniciens en 3 lettres avec une macro remplacer. Puis je filtre les ligne où la cellule A contient "+". Est ce ça qui peux poser problème?

Merci d'avance

Ophé

 

[Gruick]

Re : Macro avec une fonction si avec plusieurs réponses

re,

lorsqu'il y a 3 caractères (exemple : LAN) je voudrais que "LAN" ne s'affiche pas en colonne X. Est ce possible?

Comme après la macro il n'y aura que des codes de 3 lettres en colonne A, Ce que tu veux en X, c'est le ou les autres s'il y en a. Faisable.

j'ai eu un beug sur ce passage "If Len(Cells(i, 1)) = 7 Then 'inserer 1 ligne"

Cela ne vient pas de ma macro, ce qu'il y a en A fait soit 3, soit 7, soit 11 caractères. L'instruction Len les dénombre. Peut-être un espace superflu et invisible après ton traitement et avant le "mien".

Ce que je ne comprend pas, car même si je ne suis pas très douée en VBA, apparament ça fait une boucle quand pour passer à la deuxieme ligne.

Pas chez moi et avec l'exemple que tu nous donnes.

Avant d'effectuer cette macro, je reduis les noms des techniciens en 3 lettres avec une macro remplacer. Puis je filtre les ligne où la cellule A contient "+". Est ce ça qui peux poser problème?

Non, puisque je n'en tiens pas compte, je "joue" avec les caractères et leur place dans la chaîne.

C'est sans doute le fichier original et non celui que tu nous fournis qui pose un problème.

A toi

Gruick

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

re,

j'avoue que moi aussi j'ai du mal à bien cerner le problème qui persiste ...

a+

 

[Ophé]

Re : Macro avec une fonction si avec plusieurs réponses

Je vais refaire des tests, et pouvez vous me dire s'il faut que je modifie le code pour ne rien inscrire en colonne X si la colonne A n'a que 3 caractères.

 

[mromain]

Re : Macro avec une fonction si avec plusieurs réponses

re,

ma macro de hier à 11h00 semble fonctionner correctement (du moins chez moi)...

a+

 

[Gruick]

Re : Macro avec une fonction si avec plusieurs réponses

Moi itou, Romain

Je compatis donc à ton désarroi, Romain. Ton code est magnifique, mais mon mac est réfractaire au split.

La colonne classée "X", n'est plus un problème, grâce à la version 2 de ma macro, que voici :

Sub Ophé()
' Ophé Macro
' Macro enregistrée le 8/06/2009 par Gruick
i = 2
re:
If i > Cells(2 ^ 16, 1).End(xlUp).Row Then Exit Sub
  If Len(Cells(i, 1)) = 3 Then
    Cells(i, 24) = ""
    i = i + 1
  ElseIf Len(Cells(i, 1)) = 7 Then 'inserer 1 ligne
    Cells(i + 1, 1).EntireRow.Insert
    Rows(i).Copy Destination:=Rows(i + 1)
    Cells(i, 24) = Right(Cells(i, 1), 3): Cells(i + 1, 24) = Left(Cells(i, 1), 3)
    Cells(i, 1) = Left(Cells(i, 1), 3): Cells(i + 1, 1) = Right(Cells(i + 1, 1), 3)
    Cells(i, 19) = Cells(i, 19) / 2: Cells(i + 1, 19) = Cells(i, 19)
    Cells(i, 20) = Cells(i, 20) / 2: Cells(i + 1, 20) = Cells(i, 20)
    i = i + 2
  ElseIf Len(Cells(i, 1)) = 11 Then 'inserer 2 lignes
    Cells(i + 1, 1).EntireRow.Insert
    Cells(i + 1, 1).EntireRow.Insert
    Rows(i).Copy Destination:=Rows(i + 1)
    Rows(i).Copy Destination:=Rows(i + 2)
    Cells(i, 24) = Right(Cells(i, 1), 7)
    Cells(i + 1, 24) = Left(Cells(i, 1), 3) & Right(Cells(i, 1), 4)
    Cells(i + 2, 24) = Left(Cells(i, 1), 7)
    Cells(i, 1) = Left(Cells(i, 1), 3)
    Cells(i + 1, 1) = Mid(Cells(i + 1, 1), 5, 3)
    Cells(i + 2, 1) = Right(Cells(i + 2, 1), 3)
    Cells(i, 19) = Cells(i, 19) / 3: Cells(i + 1, 19) = Cells(i, 19): Cells(i + 2, 19) = Cells(i, 19)
    Cells(i, 20) = Cells(i, 20) / 3: Cells(i + 1, 20) = Cells(i, 20): Cells(i + 2, 20) = Cells(i, 20)
    i = i + 3
  End If
GoTo re
End Sub

J'ai fait quelques modifications sur le i et ajouté des lignes pour X raisons...ah, ah,

Belle Ophélie (forcément), la balle est dans ton camp.

Gruick