XL 2013 Recherche indexée avec lien hypertexte

[Marc-Mayotte]

Bonjour le Forum, bonjour à toutes et tous,

Je souhaite sans y parvenir retrouver le lien hypertexte contenu dans les cellules d'un onglet différent.

L'onglet "Recherche" contient 67 formules matricielles qui recherchent et affichent le résultat du contenu de l'onglet "Liste".
L'onglet "Liste" dispose en ligne C1de jusqu'à BQ1. Des "x" indiquent s'il faut afficher l'entête de colonne avec le lien ou non.
Le critère de recherche croisé est le code NAF placé en "Recherche" B1.
Les liens renvoient à un emplacement unique (mais toujours dans la même colonne) en onglet "Tarif".

Je sèche complétement et j'imagine que la solution ,passe par VBA, où je suis incompétent...

Je vous remercie d'avoir pris le temps de lire ma question.

Bonne journée,

Marc.

 

[job75]

Bonjour Marc-Mayotte,

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

Private Sub ComboBox1_Change()
Dim dest As Range, i As Variant, j%, n%
Set dest = [E17] 'cellule de destination à adapter
Application.ScreenUpdating = False
[D4] = "": dest.EntireRow.Clear 'RAZ
With Sheets("liste")
    i = Application.Match(ComboBox1, .Columns(1), 0)
    If IsError(i) Then Exit Sub
    [D4] = .Cells(i, 2)
    For j = 3 To .[A1].CurrentRegion.Columns.Count
        If LCase(.Cells(i, j)) = "x" Then n = n + 1: .Cells(1, j).Copy dest(1, n)
    Next
End With
End Sub

A+

 

[Marc-Mayotte]

Bonjour Job75,

La macro fonctionne bien. c'est assez (très) long pour afficher le résultat...Serait-il possible d'afficher les résultats sur une ligne de 12 résultats puis en dessous, etc.
Le retour actuel se fait sur une seule et est difficilement exploitable.
Un grand merci pour ce retour, quand je pense à mes formules matricielles ...J'ai vraiment besoin d'une formation VB ;-).
Marc.

 

[job75]

Bonjour Marc-Mayotte,

Je ne vois pas pourquoi ce serait très long, il y a seulement un maximum de 67 cellules à copier, ce n'est rien du tout.

Mais vous avez peut être des formules (volatiles ?) qui se recalculent, alors :

- mettez en début de macro Application.Calculation = xlCalculationManual

- et en fin de macro Application.Calculation = xlCalculationAutomatic

Pour le reste je ne comprends pas du tout ce que vous voulez faire, il ne peut y avoir qu'une seule ligne de résultats.

Bonne journée.

 

[Marc-Mayotte]

Bonjour Job75,

Merci pour la réponse ;-)
Je souhaiterais obtenir ce résultat en pièce jointe.
Pour bien comprendre, à Mayotte, chaque code NAF dispose d'exonérations à l'importation sur des nomenclatures douanières bien spécifiques.
Je souhaite donc aider mes clients afin qu'ils puissent afficher les nomenclatures pour lesquelles ils sont éxonérés et surtout, une fois ces nomenclatures affichées, le lien hypertexte renvoi sur le tarif des douanes à la nomenclature concernée pour en comprendre la teneur exacte.
Je ne peux pas joindre le tarif car beaucoup trop lourd, mais il y aura environ 584 liens, d'où l'importance de mettre un retour à la ligne.

Un grand merci,

Marc.

 

[job75]

Bon d'accord, vous voulez découper la ligne des résultats en paquets de 12 cellules, alors voyez ce fichier et la macro :

Private Sub ComboBox1_Change()
Dim dest As Range, i As Variant, lig&, j%, col%
Set dest = [D12] '1ère cellule de destination, à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[D4] = "": dest.Resize(Rows.Count - dest.Row + 1, 12).Clear 'RAZ
With Sheets("liste")
    i = Application.Match(ComboBox1, .Columns(1), 0)
    If IsNumeric(i) Then
        [D4] = .Cells(i, 2)
        lig = 1
        For j = 3 To .[A1].CurrentRegion.Columns.Count
            If LCase(.Cells(i, j)) = "x" Then
                col = col + 1
                .Cells(1, j).Copy dest(lig, col)
                With dest(lig, col)
                    .Interior.Color = RGB(255, 199, 206)
                    .Font.Color = RGB(156, 0, 6)
                    .Borders.Weight = xlHairline
                End With
                If col = 12 Then lig = lig + 1: col = 0
            End If
        Next
    End If
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Il n'y a plus de MFC ni de formules donc les Application.Calculation ne sont pas nécessaires mais je les laisse quand même.

 

[Marc-Mayotte]

Excellent! Merci beaucoup Job75. C'est exactement le résultat espéré.
Une excellente journée.
Marc.

 

[job75]

J'ai testé avec 584 liens : chez moi sur Win 10 - Excel 2019 la macro s'exécute en 1,7 seconde.

 

[Marc-Mayotte]

Oui, moi également, c'est top!!!
Encore merci.

 

[Marc-Mayotte]

Bonjour Job75,
Désolé d'être de retour...Avec de vrais liens hypertextes, le temps de traitement est terriblement long. J'ai essayé sur 4 PC différents avec des processeurs + ou - performants et c'est la même chose?
Y a-t'il un réglage particulier à faire ou ?

Merci,
Marc.

 

[job75]

Bonjour Marc-Mayotte,

Ce sera peut-être plus rapide en utilisant la fonction LIEN_HYPERTEXTE, essayez cette macro du fichier (2) :

Private Sub ComboBox1_Change()
Dim dest As Range, i As Variant, lig&, j%, col%, ad$
Set dest = [D12] '1ère cellule de destination, à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[D4] = "": dest.Resize(Rows.Count - dest.Row + 1, 12).Clear 'RAZ
With Sheets("liste")
    i = Application.Match(ComboBox1, .Columns(1), 0)
    If IsNumeric(i) Then
        [D4] = .Cells(i, 2)
        lig = 1
        For j = 3 To .[A1].CurrentRegion.Columns.Count
            If LCase(.Cells(i, j)) = "x" Then
                col = col + 1
                ad = .Cells(1, j).Hyperlinks(1).Address
                If ad = "" Then ad = "#" & .Cells(1, j).Hyperlinks(1).SubAddress
                dest(lig, col) = "=HYPERLINK(""" & ad & """,""" & .Cells(1, j) & """)" 'fonction LIEN_HYPERTEXTE
                With dest(lig, col)
                    .Interior.Color = RGB(255, 199, 206)
                    .Font.Color = RGB(156, 0, 6)
                    .Borders.Weight = xlHairline
                End With
                If col = 12 Then lig = lig + 1: col = 0
            End If
        Next
    End If
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Edit 1 : testé avec 584 liens => 0,16 seconde chez moi donc 10 fois plus rapide qu'en copiant les cellules.

Edit 2 : en fait c'est 30 fois plus rapide car les mises en forme prennent 0,11 s donc l'entrée des fonctions prend 0,05 s.

Et les Application.Calculation ne sont pas inutiles, ils économisent 0,05 s.

A+

 

[Marc-Mayotte]

Bonjour Job75,

Effectivement, c'est la solution.
Chapeau bas M'sieur et bon WE,

Marc.

 

[job75]

Ce serait sympa de nous donner les 2 durées d'exécution sur votre fichier réel.

 

[Marc-Mayotte]

C'est quasi instantané, en tout cas moins d'une seconde avec un i7.
Encore merci et bon WE.
Pour moi, ici avec le petit décalage, la semaine est finie !