Copier Valeurs et liens hypertexte

Sub Vers_Réalisé()

Dim Chemin As String
Dim NomFichier As String
Dim NomFichierEtChemin As String
Dim NomFichierSource As String

Dim addLien As String, sLien As String, NomFeuil As String
Dim vdate As Date, Montant As String ' Montant As Double ??


Application.ScreenUpdating = False
On Error Resume Next
NomFichierSource = ActiveWorkbook.Name

Chemin = Sheets("Liens_CR").Range("A2")
NomFichierEtChemin = Chemin & "Realisé-Test" & ".xlsm"
NomFichier = "Realisé-Test" & ".xlsm"


addLien = Workbooks(NomFichierSource).Sheets("Liens_CR").Range("AD15").Hyperlinks(1).Address ' A Appliquer à : range.("AC15:AH15")
sLien = Workbooks(NomFichierSource).Sheets("Liens_CR").Range("AD15").Hyperlinks(1).TextToDisplay 'A Appliquer à : range.("AC15:AH15") 'Liens hypertexte
Renseignemnt = Workbooks(NomFichierSource).Sheets("Liens_CR").Range("A15:AB15") 'A Appliquer à : range.("A15:AB15") ' Valeurs uniquement

'Application.ScreenUpdating = False
Workbooks.Open Filename:=NomFichierEtChemin

'For i = 0 To 29 'For i NOK car copie toujours la même
With Sheets("REALISE")
.Activate
dl = .Range("A65536").End(xlUp).Row + 1
.Cells(dl, 30).Hyperlinks.Add .Cells(dl, 30), addLien, , , sLien ' A Appliqyer à 30 à 35 (colonne AB = 30)
.Cells(dl, 1) = Renseignemnt ' A Appliquer à : 1 à 29
End With
'Next i


End Sub

Cliquez pour agrandir...

.Cells(dl, 2) = b
.Cells(dl, 3) = c
.Cells(dl, 4) = d
.Cells(dl, 5) = e
...

Cliquez pour agrandir...