XL 2013 Recherche indexée avec lien hypertexte

Marc-Mayotte

XLDnaute Nouveau
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.
 

Pièces jointes

  • exo avec liens hyper.xlsm
    41.5 KB · Affichages: 8

job75

XLDnaute Barbatruc
Bonjour Marc-Mayotte,

Voyez le fichier joint et cette macro dans le code de la feuille de la ComboBox :
VB:
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+
 

Pièces jointes

  • exo avec liens hyper(1).xlsm
    37.4 KB · Affichages: 9

Marc-Mayotte

XLDnaute Nouveau
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

XLDnaute Barbatruc
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

XLDnaute Nouveau
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.
 

Pièces jointes

  • Exemple.xlsm
    43.4 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bon d'accord, vous voulez découper la ligne des résultats en paquets de 12 cellules, alors voyez ce fichier et la macro :
VB:
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.
 

Pièces jointes

  • Exemple(1).xlsm
    35.4 KB · Affichages: 7

Marc-Mayotte

XLDnaute Nouveau
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

XLDnaute Barbatruc
Bonjour Marc-Mayotte,

Ce sera peut-être plus rapide en utilisant la fonction LIEN_HYPERTEXTE, essayez cette macro du fichier (2) :
VB:
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+
 

Pièces jointes

  • Exemple(2).xlsm
    37 KB · Affichages: 5
Dernière édition:

Discussions similaires