XL 2010 Récupération Cellule

[NICOALBERT]

Bonsoir le Forum ,

Je viens vers vous car j'ai un soucis avec un fichier .

Après de multiple recherche sur le forum et d'autre site pas moyen de résoudre mon soucis.

Je cherche à récupérer en VBA plusieurs cellule correspondant à un même numéro dans la feuille "Base"et les mettre dans une seul cellule à la suite en gardant leur couleur de texte dans la feuille "Resultat" .

Je ne sait pas si je m'explique bien , je vous joint un fichier exemple qui parlera mieux .

Cdlt Nicoalbert .

 

[sylvanu]

Bonjour Nico,
Un essai en PJ à vérifier.
J'ai testé quelques combinaisons sans problème.
Pour l'instant il n'y a aucune sécurité ( Désignation vide, N° absent ... )
On pourra peaufiner si ça marche.

 

[NICOALBERT]

Bonjour sylvanu , le Forum,

Je vient de faire l'essai de ton fichier et il marche très bien et je t'en remercie.

Mais lorsque je modifie les N° dans ma feuille "Base" , la macro ne le reconnait pas (exemple si à la place de 1 je met 67 ).

Serait-il possible en fait que dans la feuille "Resultat" on liste les N° différent (de la feuille "Base") et ensuite faire le fusionnage en fonction des N° présent dans cette feuille .

Encore un grand merci pour ton aide .

 

[sylvanu]

Re,
Je suis parti du principe que les N° présent dans Base étaient dans Résultat.
Dans ce cas, il faut reconstruire le tableau Resultat avant de faire la mise à jour.
Je regarde.

 

[NICOALBERT]

Merci beaucoup .

Est ce qu'il est possible aussi par exemple , si je masque une ligne dans la feuille "Base" quelle ne soit pas prise en compte dans la feuille "Resultat" ?

 

[sylvanu]

Voilà une V3 avec :
1- La reconstruction de la liste de N°
2- La non prise en compte des lignes masquées dans la base.
Après vérif, si tout est bon, il faut remettre la première ligne opérationnelle.
'Application.ScreenUpdating = False en retirant l'aspostrophe, ça accélérera grandement le processus de mise à jour.

 

[NICOALBERT]

Je viens de faire l'essai et par exemple lorsque je masque la ligne 20 , elle me l'affiche tout de même dans la Feuille "Resultat" .

 

[NICOALBERT]

Est il possible d'ajouter des lettre , car en général les n° de devis on des lettres et des chiffres ?.

Désolé , j'aurais du bien préciser tout ça au début car je suis conscient qu'au vu du boulot abattu ça te fait faire beaucoup de modif pour rien .

 

[sylvanu]

Désolé pas dans la structure actuelle.
Je me suis basé sur le premier post où tout était numérique, donc j'utilise ces nombres comme index.
Passer en alpha fait qu'on ne plus plus utiliser ce système.

 

[NICOALBERT]

je comprend tout à fait l'erreur est de mon côté , J'aurais du expliquer tout dès le début

 

[sylvanu]

A essayez, ça a l'air de marcher.
Les N° sont triés Num puis Alpha.

 

[NICOALBERT]

Super ça marche super bien .

Je te remercie beaucoup pour le temps (et le temps perdu par ma faute) pour m'aider.

@+ Nicoalbert

 

[job75]

Bonsoir NICOALBERT, sylvanu,

Voyez le fichier joint et cette macro dans le code de la feuille "Resultat" :

Private Sub Worksheet_Activate()
Dim d As Object, i&, v, col&, n&, resu$(), a, s1, s2, j%, k%
'---tableau des résultats---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Base").[A1].CurrentRegion
    For i = 2 To .Rows.Count
        v = .Cells(i, 1).Value
        If d.exists(v) Then
            col = d(v)
            resu(1, col) = resu(1, col) & vbLf & .Cells(i, 2)
            resu(2, col) = resu(2, col) & " " & Len(.Cells(i, 2))
            resu(3, col) = resu(3, col) & " " & .Cells(i, 2).Font.Color
        Else
            n = n + 1
            d(v) = n 'mémorise la colonne
            ReDim Preserve resu(1 To 3, 1 To n)
            resu(1, n) = .Cells(i, 2)
            resu(2, n) = Len(.Cells(i, 2))
            resu(3, n) = .Cells(i, 2).Font.Color
        End If
    Next i
End With
If n Then a = d.keys
'---restitution---
Application.ScreenUpdating = False
With [A2] '1ère cellule de destination, à adapter
    .Cells(1, 2).Resize(Rows.Count - .Row + 1).Font.ColorIndex = xlAutomatic
    For i = 1 To n
        .Cells(i, 1) = a(i - 1)
        .Cells(i, 2) = resu(1, i)
        s1 = Split(resu(2, i)) 'longueur
        s2 = Split(resu(3, i)) 'couleur
        k = 1
        For j = 0 To UBound(s1)
            .Cells(i, 2).Characters(k, s1(j)).Font.Color = s2(j)
            k = k + s1(j) + 1
    Next j, i
    If n Then .Resize(n).EntireRow.AutoFit 'ajustement hauteurs
    .Offset(n).Resize(Rows.Count - n - .Row + 1).EntireRow.Delete 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Elle se déclenche quand on active la feuille.

Edit : j'ai repris les numéros de devis de sylvanu.

A+

 

[NICOALBERT]

Bonjour Job75 , sylvanu , le Forum,

Ton fichier fonction parfaitement également , un grand merci à vous 2 .

Cdlt Nicoalbert