besoin des meilleurs VB istes du forum

[fred94000]

bonjour a tous et le forum,
je sollicite votre aide pour un problème un peu compliqué à expliquer.
je vous joins un fichier exemple.
le 1er tableau correspond a une extraction,
le 2ème ce que je souhaiterais.

en espérant que cela soit possible,
en attendant merci par avance.

 

[Staple1600]

Re : besoin des meilleurs VB istes du forum

Bonsoir à tous

fred94000
Tu peux détailler tes explications dans ta discussion, svp.
(Plutôt que directement dans ton fichier joint)
Histoire de savoir si je suis susceptible de t'aider avant de télécharger ta PJ.

PS: Tu peux aussi éditer le titre de ton message pour qu'il soit explicite, stp
Mais tu sais déjà tout cela, ces conseils étant dans la charte du forum...

 

[fred94000]

Re : besoin des meilleurs VB istes du forum

bonsoir Staple1600 et le forum,
Je vais essayer de t'expliquer.
la ligne 1 correspond a des dates
dans le tableau en colonne 1 cellules A2:A13 correspondent a une liste de services.

La cellule A14:a19 correspondent a deux services séparées par une virgule de la liste ci-dessus.
le reste du tableau correspond à des nombres

je voudrais par VBA en fonction des deux services A14:A19, ainsi qu'à la date B1:AE1 correspondante, ajouter la moitié de la somme de la cellule dans le tableau ci dessus.

Je ne sais pas si j'ai été assez claire.

 

[Staple1600]

Re : besoin des meilleurs VB istes du forum

Re

Merci pour les explications
J'ai donc ouvert ta PJ.
Et j'ai toujours du mal à comprendre
Heureusement je ne suis pas seul sur le forum.
D'autres ici, j'en suis sur, auront la comprenette plus efficace pour t'aider

 

[Hervé]

Re : besoin des meilleurs VB istes du forum

salut

tentative de réponse en pièce jointe.

je ne trouve pas les mêmes résultats, dit moi si c'est ok, je te commenterai le code.

renvoi à partir de la ligne 43

Private Sub CommandButton1_Click()
Dim tablo, t
Dim i As Byte, j As Integer, k As Byte, l As Byte


tablo = Range("a1").CurrentRegion


For i = 2 To UBound(tablo, 2)
    For j = UBound(tablo, 1) To UBound(tablo, 1) - 6 Step -1
        t = Split(tablo(j, 1), ",")
        For k = 0 To UBound(t)
            For l = 2 To UBound(tablo, 1) - 6
                If tablo(l, 1) = CInt(t(k)) Then
                    tablo(l, i) = tablo(l, i) + tablo(j, i) / 2
                End If
            Next l
        Next k
    Next j
Next i
    
Cells(43, 1).Resize(UBound(tablo, 1) - 6, UBound(tablo, 2)) = tablo

End Sub

 

[fred94000]

Re : besoin des meilleurs VB istes du forum

Bonsoir Hervé,
tu as très bien compris ce que je voulais obtenir malgré mes informations un peu scabreuses.
VBA impéccable.
Juste une petite erreur sur la ligne 55 du service 12, nous devrions obtenir 250 au lieu de 375
mais sinon fonctionne très bien.
milles merci.

 

[fred94000]

Re : besoin des meilleurs VB istes du forum

Bonsoir Hervé et le forum,
Je te joins le fichier regarde en feuil2 j'ai essayé d'appliquer ta formule sur mon fichier perso mais elle ne fonctionne qu'en partie.
D'autre part est-il possible de supprimer après avoir exécuter la macro les lignes en bleu sachant que dans le 1er tableau il n'y a 42 services et qu'il peut en avoir beaucoup plus
cordialement et encore merci

 

[job75]

Re : besoin des meilleurs VB istes du forum

Bonjour,

Comme il n'y a toujours que 2 nombres dans chaque cellule de la plage A14:A19, le problème est très facile à régler par formule matricielle.

Entrez donc en B28 la formule matricielle :

=B2+SOMME(SI(ESTNUM(TROUVE(","&$A2&",";","&$A$14:$A$19&","));B$14:B$19/2))

A valider par Ctrl+Maj+Entrée et tirer vers la droite et vers le bas.

Bien sûr adaptez au fichier réel en modifiant la référence de la plage $A$14:$A$19.

VBA c'est très bien mais à éviter quand c'est inutile.

Fichier joint.

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Re,

Bah même pas besoin de la validation matricielle avec SOMMEPROD :

=B2+SOMMEPROD(ESTNUM(TROUVE(","&$A2&",";","&$A$14:$A$19&","))*B$14:B$19/2)

Fichier (2).

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Re,

Si l'on veut absolument du VBA, une solution est d'entrer la formule précédente dans les cellules et de garder seulement les valeurs :

Sub Mise_à_jour()
Dim S As Range, B As Range, dest As Range, ad1$, ad2$, ad3$, ad4$, F$
Set S = [A1:AF13] 'à adapter
Set B = [A14:A19] 'à adapter
Set dest = [A27] 'à adapter
ad1 = S(2, 2).Address(0, 0, xlR1C1, , dest(2, 2))
ad2 = S(2, 1).Address(0, 1, xlR1C1, , dest(2, 2))
ad3 = B.Address(ReferenceStyle:=xlR1C1)
ad4 = B.Columns(2).Address(1, 0, xlR1C1, , dest(2, 2))
F = "=" & ad1 & "+SUMPRODUCT(ISNUMBER(FIND("",""&" & ad2 & _
  "&"","","",""&" & ad3 & "&"",""))*" & ad4 & "/2)"
Application.ScreenUpdating = False
Rows(dest.Row & ":" & Rows.Count).Clear 'RAZ
S.Copy dest 'pour les en-têtes de lignes et colonnes
With dest(2, 2).Resize(S.Rows.Count - 1, S.Columns.Count - 1)
  .FormulaR1C1 = F 'entre la formule F dans la plage
  .Value = .Value 'supprime les formules
End With
End Sub

Le code pour établir les bonnes adresses et la formule n'est pas très facile...

Fichier joint.

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Re,

Ci-joint adaptation du code au fichier du post #7.

Les tirets créent bien sûr des valeurs d'erreur #VALEUR!, d'où en fin de macro :

On Error Resume Next 's'il n'y a pas de valeurs d'erreur
.SpecialCells(xlCellTypeConstants, 16) = "-"

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Re,

Si l'on veut effacer les zéros utiliser EXP(LN()) :

Private Sub CommandButton1_Click()
Dim S As Range, B As Range, dest As Range, ad1$, ad2$, ad3$, ad4$, F$
Set S = [A4:AF46] 'à adapter
Set B = [A47:A108] 'à adapter
Set dest = [A119] 'à adapter
ad1 = S(2, 2).Address(0, 0, xlR1C1, , dest(2, 2))
ad2 = S(2, 1).Address(0, 1, xlR1C1, , dest(2, 2))
ad3 = B.Address(ReferenceStyle:=xlR1C1)
ad4 = B.Columns(2).Address(1, 0, xlR1C1, , dest(2, 2))
F = "=EXP(LN(" & ad1 & "+SUMPRODUCT(ISNUMBER(FIND("",""&" & ad2 & _
  "&"","","",""&" & ad3 & "&"",""))*" & ad4 & "/2)))"
Application.ScreenUpdating = False
Rows(dest.Row & ":" & Rows.Count).Clear 'RAZ
S.Copy dest 'pour les en-têtes de lignes et colonnes
With dest(2, 2).Resize(S.Rows.Count - 1, S.Columns.Count - 1)
  .FormulaR1C1 = F 'entre la formule F dans la plage
  .Value = .Value 'supprime les formules
  On Error Resume Next 's'il n'y a pas de valeurs d'erreur
  .SpecialCells(xlCellTypeConstants, 16) = ""
End With
End Sub

Fichier (3).

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Bonjour le fil, le forum,

Pour la solution par formule, sur Excel 2007, on utilisera SIERREUR :

=SIERREUR(EXP(LN(B5+SOMMEPROD(ESTNUM(TROUVE(","&$A5&",";","&$A$47:$A$108&","))*B$47:B$108/2)));"")

Fichier (3).

A+

 

[job75]

Re : besoin des meilleurs VB istes du forum

Re,

On remarquera qu'en A18:A23 de Feuil1 ou A47:A108 de Feuil2 on a des nombres décimaux.

Le séparateur décimal peut être la virgule ou le point suivant l'ordinateur.

Pour que les fichiers fonctionnent quel que soit le séparateur, définir le nom sep par :

=STXT(1/10;2;1)

et remplacez "," par sep dans les formules.

Fichiers (4).

A+

 

[fred94000]

Re : besoin des meilleurs VB istes du forum

Bonjour JoB75 et le forum,

Quel travail!!!!!!! du bonheur,
Exactement ce que je recherche
un très grand merci.