ecrire dans un fichier en changeant le lien hypertexte

  • Initiateur de la discussion Initiateur de la discussion obyone
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

obyone

XLDnaute Occasionnel
bonjour,
je dispose de 2 fichiers

lorsque que j'ajoute un fichier via le userform dans doc essai.xlsm onglet SI_VDO
je souhaite qu'il s'inscrive sur le tableau correspondant puis sur le tableau accueil avec son lien hypertext: "\xxx.xxx.xxx.xx\dossier\nom du fichier..."

puis dans un autre classeur nommé tachy essai.xlsm les memes copie sauf pour le lien qui deviendrait
"C:\transfert doc\dossier\nom du fichier..."

j'ai essayé cette macro mais cela ne fonctionne pas quelqu'un à une idée?

Code:
Private Sub Ajouter_click()
Dim C As Range
Dim i As Integer
Dim fic As String, monclasseur As String
tachy = "C:\Users\xxx\Desktop\Tachy essai.xlsm"

With Worksheets("Accueil").Select
   i = 2
    Do While Cells(i, 1) <> ""
      Cells(i, 4).Offset(1, 0).Select 'case selectionnée
      i = i + 1
    Loop
    ActiveCell.Offset(0, -3).Value = "VDO"
    ActiveCell.Offset(0, -2).Value = ModifVDO.TB_Noms.Value 'ajout TB noms 3 case avant
    ActiveCell.Offset(0, -1).Value = ModifVDO.TB_Date.Value 'ajout date 1 case avant
    ActiveCell.Offset(0, 0).Value = ModifVDO.TB_Description.Value 'ajout description
    ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=("\\128.60.150.7\" & Me.TB_Lien.Value)
    ActiveCell.Offset(0, 4).Value = Format(Now, "mm/dd/yyyy")
    End With
   
   With Worksheets("SI_VDO").Select
       i = 2
    Do While Cells(i, 1) <> ""
      Cells(i, 4).Offset(1, 0).Select 'case selectionnée
      i = i + 1
    Loop
    ActiveCell.Offset(0, -3).Value = ModifVDO.TB_Noms.Value 'ajout TB noms 3 case avant
    ActiveCell.Offset(0, -1).Value = ModifVDO.TB_Date.Value 'ajout date 1 case avant
    ActiveCell.Offset(0, 0).Value = ModifVDO.TB_Description.Value 'ajout description
    ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=Me.TB_Lien.Value
    If Abrogé.Value = True Then Cells(ligne, 2) = "x" 'ajout "x" si abrogé
    End With
  Range("SIVDO").Columns("a").Sort Key1:=Range("SIVDO").Columns("a"), Header:=xlYes ' tri le tableau "SIVDO" du plus petit au plus grand

'ouverture classeur tachy
Workbooks.Open (tachy)
monclasseur = ActiveWorkbook.Name

With Worksheets("Accueil").Select
   i = 2
    Do While Cells(i, 1) <> ""
      Cells(i, 4).Offset(1, 0).Select 'case selectionnée
      i = i + 1
    Loop
    ActiveCell.Offset(0, -3).Value = "VDO"
    ActiveCell.Offset(0, -2).Value = ModifVDO.TB_Noms.Value
    ActiveCell.Offset(0, -1).Value = ModifVDO.TB_Date.Value
    ActiveCell.Offset(0, 0).Value = ModifVDO.TB_Description.Value
    ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=("C:\Tranfert doc\" & Me.TB_Lien.Value)
    ActiveCell.Offset(0, 4).Value = Format(Now, "mm/dd/yyyy")
    End With
   
   With Worksheets("SI_VDO").Select
       i = 2
    Do While Cells(i, 1) <> ""
      Cells(i, 4).Offset(1, 0).Select 'case selectionnée
      i = i + 1
    Loop
    ActiveCell.Offset(0, -3).Value = ModifVDO.TB_Noms.Value 'ajout TB noms 3 case avant
    ActiveCell.Offset(0, -1).Value = ModifVDO.TB_Date.Value 'ajout date 1 case avant
    ActiveCell.Offset(0, 0).Value = ModifVDO.TB_Description.Value 'ajout description
    ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=("C:\Tranfert doc\" & Me.TB_Lien.Value)
    If Abrogé.Value = True Then Cells(ligne, 2) = "x" 'ajout "x" si abrogé
    End With
  Range("SIVDO").Columns("a").Sort Key1:=Range("SIVDO").Columns("a"), Header:=xlYes ' tri le tableau "SIVDO" du plus petit au plus grand

ActiveWorkbook.Save 'sauvegarde
Workbooks(monclasseur).Close 'fermeture

Unload Me
End Sub

merci d'avance....
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
462
Retour