Re : Copier le contenu d'une cellule dans une autre feuille par macro ???
Bonjour !
La macro fonctionne :
Public NomCalibre As String, NomBase As String, NomFeuille As String, NomFiche As String, LigneRef As Integer
Const Repertoircal = "S:\LOGICIELS QUALITE\QUALITE DEVELOPPEMENT\Moyens de Choc & Calibres\CALIBRE\Plan Dernier indice\"
Const Repertoire = "R:\Référentiel de surveillance\QR-qualité réception\Gestion des Moyens de Contrôle\"
Sub cree_fiche2()
Application.DisplayAlerts = False
ChDir (Repertoire)
NomBase = ActiveWorkbook.Name
NomFeuille = ActiveSheet.Name
NomCalibre = Cells(ActiveCell.Row, 1).Value
LigneRef = ActiveCell.Row
On Error GoTo Fichier_Vierge
Workbooks.Open Filename:=Repertoire & NomCalibre & ".xls"
On Error GoTo 0
With Workbooks(NomBase).Worksheets(NomFeuille)
Range("A8").Value = NomCalibre ' Nom du calibre
Range("A12").Value = .Cells(LigneRef, 8).Value ' Emplacement
Range("O8").Value = .Cells(LigneRef, 31).Value ' Fréquence
Range("E25").Value = .Cells(LigneRef, 14).Value ' C1
Range("G25").Value = .Cells(LigneRef, 16).Value ' C2
Range("I25").Value = .Cells(LigneRef, 18).Value ' C3
Range("K25").Value = .Cells(LigneRef, 20).Value ' C4
Range("M25").Value = .Cells(LigneRef, 22).Value ' C5
Range("E10").Formula = "=hyperlink(""" & Repertoircal & NomCalibre & ".pdf" & """,""" & "Plan calibre" & """)"
Range("D26").Select
While ActiveCell.Offset(0, -3).Value <> ""
ActiveCell.Offset(2, 0).Select
Wend
If ActiveCell.Offset(0, -3).Value <> .Cells(LigneRef, 9).Value Then
ActiveCell.Offset(0, -3).Value = .Cells(LigneRef, 9).Value ' Date d'étalonnage
ActiveCell.Value = .Cells(LigneRef, 11).Value ' Nom opérateur
ActiveCell.Offset(0, 11).Value = .Cells(LigneRef, 10).Value ' Constat / Décision
ActiveCell.Offset(0, 13).Value = .Cells(LigneRef, 32).Value ' Date prochain étalonnage
ActiveCell.Offset(0, 1).Value = .Cells(LigneRef, 15).Value ' mesure C1
ActiveCell.Offset(0, 3).Value = .Cells(LigneRef, 17).Value ' mesure C2
ActiveCell.Offset(0, 5).Value = .Cells(LigneRef, 19).Value ' mesure C3
ActiveCell.Offset(0, 7).Value = .Cells(LigneRef, 21).Value ' mesure C4
ActiveCell.Offset(0, 9).Value = .Cells(LigneRef, 23).Value ' mesure C5
' ^ ^
' | |
' ----------------- --------------------------------------------------
' | |
' Continuer ainsi de suite avec sur la partie droite les coordonnées dans la base calibres et dans la partie gauche,
' les coordonnées dans la fiche.
End If
End With
NomFiche = NomCalibre & ".xls"
ActiveWorkbook.SaveAs Filename:=Repertoire & NomFiche
ActiveWorkbook.Close
Cells(ActiveCell.Row, 1).Formula = "=hyperlink(""" & Repertoire & NomFiche & """,""" & NomCalibre & """)"
Fichier_Vierge:
If Err.Number <> 0 Then
Workbooks.Open Filename:=Repertoire & "fiche de suivi vierge.xls"
Par contre dans le cas où la date est identique et que je relance la macro les données se recopient en dessous comme pour une nouvelle date.
Comment éviter celà ?
J'ai une autre question.
Dans ma fiche de suivi j'ai un lien hypertexte vers le plan du calibre.
Existe-t-il une solution pour afficher la miniature de ce fichier (plan de la pièce en pdf) plutôt que du texte ?
Merci.