Création de lien et rangement avec incrémentation

Le 26/10/2017 à 09:54

Bonjour à tous,

Je vous expose mon problème. Je réalise en ce moment une base de données. Le but est d'engendrer une fiche crée automatiquement par des USF. Une fois la fiche finie, l'utilisateur n'a qu'a appuyé sur un bouton pour l'enregistrer via ce code:

 
ChDir "C:\Users\....\.......\"
Sheets("Fiche ").ExportAsFixedFormat Filename:=Sheets("Fiche").Range("I1").Value, Type:=xlTypePDF, Quality:= _
xlQualityStandard, includeDocproperties:=True, IgnorePrintAreas:=False, _
from:=1, To:=2, openafterpublish:=True

Jusque là tout marche bien. Maintenant je veux qu'en cliquant sur le même bouton des données telles que celles-ci

donnees

se rangent dans un tableau,comme celui-ci en s'incrémentant automatiquement ligne par ligne. ce tableau se situant dans un autre onglet de mon classeur.

tableau

De plus, j'aimerai que dans la colonne "A" du tableau qui correspond à la colonne N° de fiche soit un lien hypertexte vers cette fiche. L'enregistrement de la fiche en pdf portant déjà le nom du numéro de la fiche. Et bien sûr que cela se crée pour chaque fiche que je crée.

  With Sheets("Tableau")
Dim DerLigne As Long
      DerLigne = .Range("A" & Rows.Count).End(xlUp).Row + 1

      .Cells(DerLigne, "B") = Sheets("Fiche").Range("D7").MergeArea.Value
      .Cells(DerLigne, "C") = Sheets("Fiche").Range("D8").MergeArea.Value
      .Cells(DerLigne, "D") = Sheets("Fiche").Range("D10").MergeArea.Value
      .Cells(DerLigne, "E") = Sheets("Fiche").Range("K6").MergeArea.Value
      .Cells(DerLigne, "F") = Sheets("Fiche").Range("D4").MergeArea.Value
      .Cells(DerLigne, "G") = Sheets("Fiche").Range("K8").MergeArea.Value
      .Cells(DerLigne, "H") = Sheets("Fiche").Range("K9").MergeArea.Value
      .Cells(DerLigne, "I") = Sheets("Fiche ").Range("C12").MergeArea.Value

      Worksheets("Tableau ").Hyperlinks.Add Anchor:=Worksheets("Tableau").Range("H" & DerLigne), Address:="C:\Users\....\...\", TextToDisplay:=Sheets("Fiche").Range("I1").MergeArea.Value
  End With

J'espère que j'ai été assez clair.....

Merci d'avance, toute aide sera la bienvenue et très précieuse!

Bonne journée à vous,

Le 26/10/2017 à 10:07

Bonjour,

quel est le problème ? quelle est la question ?

Le 26/10/2017 à 10:48

Bonjour,

merci pour ta réponse,

Mon code pour l'incrémentation ne fonctionne pas et la création de lien de lien non plus. C'est ça qui me bloque.

Le 26/10/2017 à 11:28

Bonjour,

tu detemines le numéro de la première ligne vide sur base de la colonne A, dans laquelle tu sembles ne rien écrire. les données s'enregistreront donc toujours sur la même ligne.

en corrigeant cette instruction tu mettras le lien en colonne A et la détection de lignes devrait fonctionner correctement.

Worksheets("Tableau ").Hyperlinks.Add Anchor:=Worksheets("Tableau").Range("A" & DerLigne), Address:="C:\Users\....\...\", TextToDisplay:=Sheets("Fiche").Range("I1").MergeArea.Value

si ce n'est pas le cas, mets-nous un fichier dans lequel on peut reproduire le problème que tu rencontres.

Le 26/10/2017 à 11:37

J'ai rédigé ce code pour que les données se listent dans mon tableau les unes à la suite des autres et que le n° de fiche soit un lien vers le PDF de la fiche.

Cependant lors de l'evenement CLICK de mon bouton il ne se passe rien. Voici le code complet:

Private Sub CommandButton1_Click()

ChDir "C:\Users\Documents"
Sheets("Fiche").ExportAsFixedFormat Filename:=Sheets("Fiche").Range("I1").Value, Type:=xlTypePDF, Quality:= _
xlQualityStandard, includeDocproperties:=True, IgnorePrintAreas:=False, _
from:=1, To:=2, openafterpublish:=True

  With Sheets("Bibliothèque")
Dim DerLigne As Long
      DerLigne = .Range("A" & Rows.Count).End(xlUp).Row + 1

      .Cells(DerLigne, "B") = Sheets("Fiche").Range("D7").MergeArea.Value
      .Cells(DerLigne, "C") = Sheets("Fiche").Range("D8").MergeArea.Value
      .Cells(DerLigne, "D") = Sheets("Fiche").Range("D10").MergeArea.Value
      .Cells(DerLigne, "E") = Sheets("Fiche").Range("K6").MergeArea.Value
      .Cells(DerLigne, "F") = Sheets("Fiche").Range("D4").MergeArea.Value
      .Cells(DerLigne, "G") = Sheets("Fiche").Range("K8").MergeArea.Value
      .Cells(DerLigne, "H") = Sheets("Fiche").Range("K9").MergeArea.Value
      .Cells(DerLigne, "I") = Sheets("Fiche").Range("C12").MergeArea.Value

      Worksheets("Bibliothèque").Hyperlinks.Add Anchor:=Worksheets("Bibliothèque").Range("H" & DerLigne), Address:="C:\Users\Documents", TextToDisplay:=Sheets("Fiche").Range("I1").MergeArea.Value
  End With

End Sub
Le 26/10/2017 à 11:49

Bonjour,

proposition de correction de ton code

Private Sub CommandButton1_Click()
    ChDir "c:\users\Documents"
    Sheets("Fiche").ExportAsFixedFormat Filename:=Sheets("Fiche").Range("I1").Value, Type:=xlTypePDF, Quality:= _
                                        xlQualityStandard, includeDocproperties:=True, IgnorePrintAreas:=False, _
                                        from:=1, To:=2, openafterpublish:=True
    With Sheets("Bibliothèque")
        Dim DerLigne As Long
        DerLigne = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Cells(DerLigne, "B") = Sheets("Fiche").Range("D7").MergeArea.Value
        .Cells(DerLigne, "C") = Sheets("Fiche").Range("D8").MergeArea.Value
        .Cells(DerLigne, "D") = Sheets("Fiche").Range("D10").MergeArea.Value
        .Cells(DerLigne, "E") = Sheets("Fiche").Range("K6").MergeArea.Value
        .Cells(DerLigne, "F") = Sheets("Fiche").Range("D4").MergeArea.Value
        .Cells(DerLigne, "G") = Sheets("Fiche").Range("K8").MergeArea.Value
        .Cells(DerLigne, "H") = Sheets("Fiche").Range("K9").MergeArea.Value
        .Cells(DerLigne, "I") = Sheets("Fiche").Range("C12").MergeArea.Value
        .Hyperlinks.Add Anchor:=Range("A" & DerLigne), Address:="C:\users\Documents\" & Sheets("Fiche").Range("I1").MergeArea.Value, TextToDisplay:=Sheets("Fiche").Range("I1").MergeArea.Value
    End With
End Sub
Le 26/10/2017 à 13:03

Merci de m'aider,

J'ai remplacé mon code par ton code, mais malheuresuement il m'affiche une incompatibilité de type "erreur 13" à la ligne de la création du lien...

voici mon fichier ci joint,

7tvbfl.xlsm (78.87 Ko)
Le 26/10/2017 à 14:04

bonjour,

proposition de correction

Private Sub CommandButton1_Click()
rep = "C:\Users\LFebvet\Documents\PFE\Intermédiaire\"

Sheets("Fiche REX").ExportAsFixedFormat Filename:=rep & Sheets("Fiche REX").Range("I1").Value, Type:=xlTypePDF, Quality:= _
xlQualityStandard, includeDocproperties:=True, IgnorePrintAreas:=False, _
from:=1, To:=2, openafterpublish:=True

 For Each s In Sheets("Fiche REX").Shapes
    If Not Intersect(s.TopLeftCell, Range("$A$43:$N$77")) Is Nothing Then
       s.Delete
    End If
  Next s

   For Each m In Sheets("Fiche REX").Shapes
    If Not Intersect(m.TopLeftCell, Range("L25:L27")) Is Nothing Then
       m.Fill.ForeColor.RGB = RGB(255, 255, 255)
    End If
  Next m

  With Sheets("Bibliothèque REX").ListObjects("tableau1").ListRows.Add

      '.Range.Cells(1, "B") = UserForm2.TextBox1.Value 'donne une erreur car pas de userform2
      .Range.Cells(1, "C") = Sheets("Fiche REX").Range("D8").Value
      .Range.Cells(1, "D") = Sheets("Fiche REX").Range("D10").Value
      .Range.Cells(1, "E") = Sheets("Fiche REX").Range("K6").Value
      .Range.Cells(1, "F") = Sheets("Fiche REX").Range("D4").Value
      .Range.Cells(1, "G") = Sheets("Fiche REX").Range("K8").Value
      .Range.Cells(1, "H") = Sheets("Fiche REX").Range("K9").Value
      .Range.Cells(1, "I") = Sheets("Fiche REX").Range("C12").Value
      ad = rep & Sheets("Fiche REX").Range("I1").Value & ".pdf"
      td = Sheets("Fiche REX").Range("I1").Value & ""
      Worksheets("Bibliothèque REX").Hyperlinks.Add Anchor:=.Range.Cells(1, "H"), Address:=ad, TextToDisplay:=td
  End With

Sheets("Fiche REX").Range("D4").MergeArea.ClearContents
Sheets("Fiche REX").Range("D6").MergeArea.ClearContents
Sheets("Fiche REX").Range("F6").MergeArea.ClearContents
Sheets("Fiche REX").Range("H6").MergeArea.ClearContents
Sheets("Fiche REX").Range("K6").MergeArea.ClearContents
Sheets("Fiche REX").Range("D7").MergeArea.ClearContents
Sheets("Fiche REX").Range("K7").MergeArea.ClearContents
Sheets("Fiche REX").Range("D8").MergeArea.ClearContents
Sheets("Fiche REX").Range("B9").MergeArea.ClearContents
Sheets("Fiche REX").Range("E9").MergeArea.ClearContents
Sheets("Fiche REX").Range("K9").MergeArea.ClearContents
Sheets("Fiche REX").Range("K8").MergeArea.ClearContents
Sheets("Fiche REX").Range("D10").MergeArea.ClearContents
Sheets("Fiche REX").Range("K10").MergeArea.ClearContents
Sheets("Fiche REX").Range("M10").MergeArea.ClearContents
Sheets("Fiche REX").Range("B11").MergeArea.ClearContents
Sheets("Fiche REX").Range("E11").MergeArea.ClearContents
Sheets("Fiche REX").Range("K11").MergeArea.ClearContents
Sheets("Fiche REX").Range("C12").MergeArea.ClearContents
Sheets("Fiche REX").Range("G12").MergeArea.ClearContents
Sheets("Fiche REX").Range("L12").MergeArea.ClearContents
Sheets("Fiche REX").Range("D13").MergeArea.ClearContents
Sheets("Fiche REX").Range("D16").MergeArea.ClearContents
Sheets("Fiche REX").Range("M17").MergeArea.ClearContents
Sheets("Fiche REX").Range("M18").MergeArea.ClearContents
Sheets("Fiche REX").Range("M19").MergeArea.ClearContents
Sheets("Fiche REX").Range("M20").MergeArea.ClearContents
Sheets("Fiche REX").Range("M21").MergeArea.ClearContents
Sheets("Fiche REX").Range("M22").MergeArea.ClearContents
Sheets("Fiche REX").Range("M23").MergeArea.ClearContents
Sheets("Fiche REX").Range("N17").MergeArea.ClearContents
Sheets("Fiche REX").Range("N18").MergeArea.ClearContents
Sheets("Fiche REX").Range("N19").MergeArea.ClearContents
Sheets("Fiche REX").Range("N20").MergeArea.ClearContents
Sheets("Fiche REX").Range("N21").MergeArea.ClearContents
Sheets("Fiche REX").Range("N22").MergeArea.ClearContents
Sheets("Fiche REX").Range("N23").MergeArea.ClearContents
Sheets("Fiche REX").Range("D24").MergeArea.ClearContents
Sheets("Fiche REX").Range("D29").MergeArea.ClearContents
Sheets("Fiche REX").Range("D30").MergeArea.ClearContents
Sheets("Fiche REX").Range("D31").MergeArea.ClearContents
Sheets("Fiche REX").Range("D32").MergeArea.ClearContents
Sheets("Fiche REX").Range("D33").MergeArea.ClearContents
Sheets("Fiche REX").Range("D34").MergeArea.ClearContents
Sheets("Fiche REX").Range("D35").MergeArea.ClearContents
Sheets("Fiche REX").Range("D36").MergeArea.ClearContents
Sheets("Fiche REX").Range("K31").MergeArea.ClearContents
Sheets("Fiche REX").Range("K33").MergeArea.ClearContents
Sheets("Fiche REX").Range("C37").MergeArea.ClearContents
Sheets("Fiche REX").Range("C39").MergeArea.ClearContents
Sheets("Fiche REX").Range("J37").MergeArea.ClearContents
Sheets("Fiche REX").Range("J39").MergeArea.ClearContents
Sheets("Fiche REX").Range("K35").MergeArea.ClearContents
Sheets("Fiche REX").Range("K37").MergeArea.ClearContents
Sheets("Fiche REX").Range("K38").MergeArea.ClearContents
Sheets("Fiche REX").Range("K40").MergeArea.ClearContents

End Sub
Le 26/10/2017 à 14:14

Re,

J'ai testé, le code ne m'affiche pas d'erreurs mais rien ne se marque dans mon onglet Bibliothèque . Je ne comprends pas pourquoi.

J'ai bien mis .MergeArea car ce sont des cellules fusionnées mais c'est comme s'il ne trouvait pas les valeurs

merci,

Le 26/10/2017 à 14:22
tvbfl a écrit :

Re,

J'ai testé, le code ne m'affiche pas d'erreurs mais rien ne se marque dans mon onglet Bibliothèque . Je ne comprends pas pourquoi.

[\quote]

regarde à la fin de ton tableau

J'ai bien mis .MergeArea car ce sont des cellules fusionnées mais c'est comme s'il ne trouvait pas les valeurs

merci,

si j'ai enlevé .mergearea, c'est qu'il y a une raison ..., mergearea permet de selectionner toutes les cellules d'une fusion de cellules, chez moi cela provoque une erreur quand tu veux exploiter la valeur qui en résulte.

Le 26/10/2017 à 14:36

Oui excuse moi je n'avais pas remarqué que tu les avais enlevés,

Les valeurs semblent se diriger vers la feuille Bibliothèque puisque dans le filtre de chaque colonne apparait des valeurs mais pourquoi ne sont elles pas visible dans les tableaux ?

Le lien ne se crée pas non plus, est ce que ça serait un problème de chemin ?

Le 26/10/2017 à 14:49

re-bonjour,

bonjour, ton fichier exemple avec la macro qui fonctionne chez moi.

6tvbfl.xlsm (44.67 Ko)
Le 26/10/2017 à 15:18

Bonjour,

C'est bon, c'est parfait.

Je te remercie beaucoup d'avoir pris le temps de répondre à mes questions et m'avoir aider à avancer.

Bonne fin de journée,

Rechercher des sujets similaires à "creation lien rangement incrementation"