XL 2010 Chargement Bdd en lien hypertexte depuis usb

B

BUG

XLDnaute Junior
Bonjour à tous,

Je sollicite si possible votre aide pour un néophyte catastrophique…
J’ai trouvé un code sur le site qui correspondrait presque à ma quête,
Sauf qu’évidement je n’arrive pas me l adapté.
A l’ouverture du classeur, le code doit charger dans une feuille les titres
Des fichiers en lien Hypertexte situés dans une clé USB
G :\BASE DE DONNEES.
Ça marche seulement si le classeur se trouve dans le même fichier, surement
du répertoire = ThisWorkbook.Path & "\"

Tout aide me sera bien précieuse, merci


Private Sub Workbook_Open()
Application.ScreenUpdating = False
Range("A2:A65000").ClearContents
repertoire = ThisWorkbook.Path & "G\BASE DE DONNEES"
[H4] = repertoire
ligne = 4
nf = Dir(repertoire & "*.*") 'on peut faire aussi premier fichier xls, pdf CA C EST COOL
Do While nf <> ""
ActiveSheet.Hyperlinks.Add Anchor:=Cells(ligne, 1), Address:=repertoire & "\" & nf, TextToDisplay:=nf
ligne = ligne + 1
nf = Dir ' fichier suivant
Loop
Range("a2:A" & [A65000].End(xlUp).Row).Sort key1:=[A2]

End Sub
 
Trier par date Trier par votes
Jacky67

Jacky67

XLDnaute Barbatruc
BUG à dit:
Bonjour à tous,

Je sollicite si possible votre aide pour un néophyte catastrophique…
J’ai trouvé un code sur le site qui correspondrait presque à ma quête,
Sauf qu’évidement je n’arrive pas me l adapté.
A l’ouverture du classeur, le code doit charger dans une feuille les titres
Des fichiers en lien Hypertexte situés dans une clé USB
G :\BASE DE DONNEES.
Ça marche seulement si le classeur se trouve dans le même fichier, surement
du répertoire = ThisWorkbook.Path & "\"

Tout aide me sera bien précieuse, merci


Private Sub Workbook_Open()
Application.ScreenUpdating = False
Range("A2:A65000").ClearContents
repertoire = ThisWorkbook.Path & "G\BASE DE DONNEES"
[H4] = repertoire
ligne = 4
nf = Dir(repertoire & "*.*") 'on peut faire aussi premier fichier xls, pdf CA C EST COOL
Do While nf <> ""
ActiveSheet.Hyperlinks.Add Anchor:=Cells(ligne, 1), Address:=repertoire & "\" & nf, TextToDisplay:=nf
ligne = ligne + 1
nf = Dir ' fichier suivant
Loop
Range("a2:A" & [A65000].End(xlUp).Row).Sort key1:=[A2]

End Sub
Cliquez pour agrandir...
Bonjour,

Essaye avec
repertoire = "G:\BASE DE DONNEES\"

La lettre du lecteur usb doit être "G"
Le dossier "BASE DE DONNEES" doit exister
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
BUG à dit:
Merci pour ta réponse Jacky,

j ai bien essayé et le dossier existe bien.
merci
Cliquez pour agrandir...
Re…
Et alors ??
Un peu vague comme réponse.
Le test avec
repertoire = "G:\BASE DE DONNEES\"
Ca donne quoi ???

**Pour le code complet, je ferais comme ceci
A placer dans le ThisWorkbook
VB: 
Private Sub Workbook_Open()
Dim Repertoire As String, Nf As String, Ligne&
Application.ScreenUpdating = False
Repertoire = "G:\BASE DE DONNEES\"
With Feuil1
  .Cells.Clear
  With .[A1]
  .Value = Repertoire: .Font.Bold = True: .Font.Size = 12: .HorizontalAlignment = xlCenter
  End With
  Ligne = 2
  Nf = Dir(Repertoire & "*.*")  'on peut faire aussi premier fichier xls, pdf CA C EST COOL
  Do While Nf <> ""
  .Hyperlinks.Add Anchor:=.Cells(Ligne, 1), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
  Ligne = Ligne + 1
  Nf = Dir  ' fichier suivant
  Loop
  .Range("a2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Sort key1:=.[A2]
  .Columns(1).AutoFit
End With
Application.ScreenUpdating = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
B

BUG

XLDnaute Junior
Bonjour Jacky,

en effet, j'ai été plutôt vague , je m 'en excuse.
Je viens de copier ton code, j 'ai remis un autre Disque dur ou cas ou (sur le port G ) et la super
cela fonctionne .

Un grand merci à toi d 'avoir pris le temps de voir mon problème.
 
Vote positif 0 Vote négatif
B

BUG

XLDnaute Junior
Bonjour Jacky , le Forum,

je reviens vers vous si possible pour "nettoyer" le code que j 'ai voulu adapté et le modifier.et la je tourne en rond !!
( en fait j ai recopié bêtement le code 3 fois en changement le type de fichier chargé et leur emplacement )
je voudrai avoir en 2 eme ligne des titres spécifiant le chargement ( ex : en A2 "tous les fichiers" , en B2 " fichiers PDF"....
Merci pour votre indulgence :(


Private Sub Workbook_Open()
'chargement de tous les fichiers avec hyperliens en colonne A
Dim Repertoire As String, Nf As String, Ligne&
Application.ScreenUpdating = False
Repertoire = "G:\BASE DE DONNEES\"
With Feuil1
.Cells.Clear
'ENDROIT OU SERA ECRIT LE CHEMIN DU repertoire
With .[A1]
.Value = Repertoire: .Font.Bold = True: .Font.Size = 14: .HorizontalAlignment = xlCenter
'essai color font de cellule
Range("A1:C1").Interior.Color = RGB(0, 160, 128)
'Epaisseur de la bordure
'Selection.Borders.Weight = 4
'Couleur de la bordure : rouge
'Selection.Borders.Color = RGB(0, 0, 0)
.BorderAround LineStyle:=xlDouble
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
'ligne ou debutera la liste
Ligne = 10
Nf = Dir(Repertoire & "*.*") ''type de fichier a rechercher ex premier fichier xls,ou pdf ....
Do While Nf <> ""
' colonne ou la liste sera ligne 1 =colonne A
.Hyperlinks.Add Anchor:=.Cells(Ligne, 1), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
Ligne = Ligne + 1
Nf = Dir ' fichier suivant
Loop
.Range("a2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Sort key1:=.[A2]
.Columns(1).AutoFit
End With
'Application.ScreenUpdating = True


'chargement de tous les fichiers PDF avec hyperliens en colonne B
With Feuil1
' Nettoyage de feuille
' .Cells.Clear
'ENDROIT OU SERA ECRIT LE CHEMIN DU repertoire
With .[B1]
'police , taille du nom du repertoire
.Value = Repertoire: .Font.Bold = True: .Font.Size = 14: .HorizontalAlignment = xlCenter
.BorderAround LineStyle:=xlDouble
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
'ligne ou debutera la liste
Ligne = 15
Nf = Dir(Repertoire & "*.pdf") 'type de fichier a rechercher ex premier fichier xls,ou pdf ....
Do While Nf <> "" ' repeter la boucle de recherche au 2 eme, 3 eme ...
' colonne ou la liste sera ligne 1 =colonne A
.Hyperlinks.Add Anchor:=.Cells(Ligne, 2), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
Ligne = Ligne + 1
Nf = Dir ' fichier suivant
Loop
.Range("b2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Sort key1:=.[B2]
.Columns(1).AutoFit
End With
Application.ScreenUpdating = True


' chargement de tous les fichiers AVI avec hyperliens en colonne C

With Feuil1
' Nettoyage de feuille
' .Cells.Clear
'ENDROIT OU SERA ECRIT LE CHEMIN DU repertoire

With .[C1]
.Value = Repertoire: .Font.Bold = True: .Font.Size = 14: .HorizontalAlignment = xlCenter
.BorderAround LineStyle:=xlDouble
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Ligne = 20
Nf = Dir(Repertoire & "*.avi")
Do While Nf <> ""
' colonne ou la liste sera ligne 1 =colonne A
.Hyperlinks.Add Anchor:=.Cells(Ligne, 3), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
Ligne = Ligne + 1
Nf = Dir ' fichier suivant
Loop
.Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row).Sort key1:=.[C2]
.Columns(1).AutoFit
End With
Application.ScreenUpdating = True


End Sub

merci. ( à noté que j 'ai vainement cherché la il est 02h20...)
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
Re..
Essaye comme ceci
VB: 
Private Sub Workbook_Open()
'chargement de tous les fichiers avec hyperliens en colonne A-B-C
Dim Repertoire As String, Nf As String, LigneColA&, LigneColB&, LigneColC&
Application.ScreenUpdating = False
Repertoire = "G:\BASE DE DONNEES\"
With Feuil1
  .Cells.Clear
  'ENDROIT OU SERA ECRIT LE CHEMIN DU repertoire
. [a1:c1] = Repertoire
  .[a2] = "Tous les fichiers":. [b2] = "Fichiers PDF":. [c2] = "Fichiers AVI"
  With .Range("A1:C2")
    .Font.Bold = True: .Font.Size = 14: .HorizontalAlignment = xlCenter
    .Borders.LineStyle = xlDouble  'Bordures
    .Interior.Color = RGB(0, 160, 128)  ' Couleur
  End With
  'lignes ou debuteront les listes des differentes colonnes
  LigneColA = 10: LigneColB = 15: LigneColC = 20
  Nf = Dir(Repertoire & "*.*")  ''type de fichier a rechercher ex premier fichier xls,ou pdf ....
  Do While Nf <> ""
    .Hyperlinks.Add Anchor:=.Cells(LigneColA, 1), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
    LigneColA =. Cells(.Rows.Count, "A").End(xlUp).Row + 1
    If UCase(Mid(Nf, InStrRev(Nf, ".") + 1)) = "PDF" Then
      .Hyperlinks.Add Anchor:=.Cells(LigneColB, 2), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
      LigneColB = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    End If
    If UCase(Mid(Nf, InStrRev(Nf, ".") + 1)) = "AVI" Then
      .Hyperlinks.Add Anchor:=.Cells(LigneColC, 3), Address:=Repertoire & "\" & Nf, TextToDisplay:=Nf
      LigneColC = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
    End If
    Nf = Dir  ' fichier suivant
  Loop
  .Range("a10:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Sort key1:=.[a10]
  .Range("b15:b" & .Cells(.Rows.Count, "b").End(xlUp).Row).Sort key1:=.[b15]
  .Range("c20:c" & .Cells(.Rows.Count, "c").End(xlUp).Row).Sort key1:=.[c20]
  .Columns("A:C").AutoFit
End With
Application.ScreenUpdating = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2019 Passage de 2013 pro à 2019 pro, Pb avec formule VBA, liens hypertexte
2 3 4
Réponses
54
Affichages
2 K
sylvanu
sylvanu
O
  • Résolu(e)
Microsoft 365 Lien hypertexte
2
Réponses
21
Affichages
1 K
job75
job75
L
  • Résolu(e)
XL 2016 Lien hypertexte VBA
Réponses
1
Affichages
964
Louu59
L
P
  • Résolu(e)
XL 2019 ajouter lien fichier dans une colonne
Réponses
3
Affichages
324
sylvanu
sylvanu
M
  • Question
Microsoft 365 Génération image en lien hypertexte lié à une variable via une boucle
Réponses
0
Affichages
736
Maad84
M
grisan29
  • Question
XL 2013 créer un lien hypertexte dans une cellule
Réponses
13
Affichages
2 K
grisan29
grisan29
A
  • Question
XL 2016 VBA Lister fichiers d'un dossier avec lien hypertexte
Réponses
1
Affichages
3 K
Roland_M
Roland_M
T
  • Question
Liens hypertexte "internes" et envoi par mail
2
Réponses
19
Affichages
3 K
titiborregan5
T
O
  • Question
Lien hypertexte valable quelque soit la lettre d'unité de la clé usb
Réponses
3
Affichages
2 K
ouaich
O
S
  • Question
Lien hypertext selon critères
Réponses
5
Affichages
13 K
stefb44
S

Membres actuellement en ligne

11 membres et 71 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 321
Messages
2 087 260
Membres
103 498
dernier inscrit
FAHDE