Copier des données d'un classeur à un autre

• Coment va-t-on envoyer les données ?

• les cellules fusionnées ennemies du VBA
• Peut-on envisagé le tableau de l'onglet visco6 sans cellules fusiuonnées ?
• pourquoi deux colonnes dans le tableau de l'onglet visco6 ?

• Dans quel onglet (nom ou position) sont éditées les données source et dans quel onglet (nom ou position) doivent-elles être copiées ?
• Quel est le chemin d'accès du fichier Source ? Du fichier Destination (Bureau ok, mais selon la version de Windows, le chemin d'accès au bureau est différent) ?
• Quelle version d'Excel utilises-tu ?

Private Sub CommandButton1_Click() 'bouton Envoi
ActiveCell.Select 'enlève le focus au bouton
Module1.Macro1 'lance la procédure [Marco1] du module [Module1]
ThisWorkbook.Sheets("lot").Range("C5:C6").ClearContents 'efface date et numéro de lot
ThisWorkbook.Sheets("Visco6").Range("A2:A17").ClearContents 'efface la liste de non conformité
End Sub

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OS1 As Worksheet 'déclare la variable OS1 (Onglet Source 1)
Dim OS2 As Worksheet 'déclare la variable OS2 (Onglet Source 2)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Byte 'déclare la variable I (Incrément)

Set CS = ThisWorkbook 'définit le classeur source CS
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OS1 = CS.Sheets("lot") 'définit l'onglet OS1
Set OS2 = CS.Sheets("visco6") 'définit l'onglet OS2
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CD = Workbooks("archive.xlsm") 'définit le classeur destination CD (génère une erreur si ce classeur est fermé)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err = 0 'annule l'erreur
    Application.Workbooks.Open (CH & "archive.xlsm") 'ouvre le classeur destination "archive.xlsm"
    Set CD = ActiveWorkbook 'définit le classeur destination CD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OD = CD.Sheets("archive 2015") 'définit l'onglet destination OD
'boucle dur tous les cellules éditées (en partant de la seconde) de la colonne 1 (=A) de l'onglet OS2
For I = 2 To OS2.Cells(Application.Rows.Count, 1).End(xlUp).Row
    Set DEST = OD.Cells(Application.Rows.Count, 3).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    DEST.Value = OS1.Range("C6").Value 'récupère la date
    DEST.Offset(0, 1).Value = OS2.Cells(I, 1).Value 'récupère le type de nom conformité
    DEST.Offset(0, 2).Value = OS1.Range("C5").Value 'récupère le numéro de lot
Next I 'prochaine ligne de la boucle
'tu peux éventuellement fermer le classeur destination avec : CD.Close SaveChanges:=True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onlget
Dim PL As Range 'déclare la variable PL (PLage)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OS1 As Worksheet 'déclare la variable OS1 (Onglet Source 1)
Dim OS2 As Worksheet 'déclare la variable OS2 (Onglet Source 2)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Byte 'déclare la variable I (Incrément)

'target désigne la cellule qui subit un changement (édition/modification/effacement)
If Target.Value = "" Then Exit Sub 'si la cellule est efffacée, sort de la procédure
If Target.Cells.Count > 1 Then Exit Sub 'si plusieurs cellules sélectionnées, sort de la procédure
Set CS = ThisWorkbook 'définit le classeur source CS
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OS1 = CS.Sheets("LOT") 'définit l'onglet OS1
Set OS2 = CS.Sheets("VISCO 6") 'définit l'onglet OS2
'définit la plage PL
Set PL = Application.Union(OS2.Range("A53:A58"), OS2.Range("I53:I58"), OS2.Range("A110:A115"), OS2.Range("I110:I115")) 'à adapter si tu rajoutes des cellules jaunes
'si le changement a lieu ailleurs qu'en PL, sort de la procédure (limite l'action de la macro à la plage PL uniquement)
If Application.Intersect(Target, PL) Is Nothing Then Exit Sub
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CD = Workbooks("archive.xlsm") 'définit le classeur destination CD (génère une erreur si ce classeur est fermé)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err = 0 'annule l'erreur
    Application.Workbooks.Open (CH & "archive.xlsm") 'ouvre le classeur destination "archive.xlsm"
    Set CD = ActiveWorkbook 'définit le classeur destination CD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OD = CD.Sheets("archive 2015") 'définit l'onglet destination OD
Set DEST = OD.Cells(Application.Rows.Count, 3).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
If OS1.Range("C7") = "" Or OS1.Range("C11") = "" Then 'condition : si le numéro de lot et/ou la date ne sont pas renseignés
    OS1.Activate 'active l'onglet OS1 (="LOT")
    OS1.Range("C7").Select 'sélectionne la cellue C7
    MsgBox "Vous devez renseigner le numéro de lot et la date !" 'message
    Exit Sub 'sort de la procédure
End If 'fin de la condition
DEST.Value = OS1.Range("C11").Value 'récupère la date
DEST.Offset(0, 1).Value = Target.Value 'récupère le type de nom conformité
DEST.Offset(0, 2).Value = OS1.Range("C7").Value 'récupère le numéro de lot
'tu peux éventuellement fermer le classeur destination avec : CD.Close SaveChanges:=True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OS1 As Worksheet 'déclare la variable OS1 (Onglet Source 1)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Byte 'déclare la variable I (Incrément)

'target désigne la cellule qui subit un changement (édition/modification/effacement)
Set CS = ThisWorkbook 'définit le classeur source CS
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OS1 = CS.Sheets("LOT") 'définit l'onglet OS1
'définit la plage PL
Set PL = Application.Union(Range("A53:A58"), Range("I53:I58"), Range("A110:A115"), Range("I110:I115")) 'à adapter si tu rajoutes des cellules jaunes
'si le changement a lieu ailleurs qu'en PL, sort de la procédure (limite l'action de la macro à la plage PL uniquement)
If Not Application.Intersect(Target, PL) Is Nothing Then
    If Target.Value = "" Then Exit Sub 'si la cellule est efffacée, sort de la procédure
    If Target.Cells.Count > 1 Then Exit Sub 'si plusieurs cellules sélectionnées, sort de la procédure
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set CD = Workbooks("archive.xlsm") 'définit le classeur destination CD (génère une erreur si ce classeur est fermé)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err = 0 'annule l'erreur
        Application.Workbooks.Open (CH & "archive.xlsm") 'ouvre le classeur destination "archive.xlsm"
        Set CD = ActiveWorkbook 'définit le classeur destination CD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    Set OD = CD.Sheets("archive 2015") 'définit l'onglet destination OD
    Set DEST = OD.Cells(Application.Rows.Count, 3).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    If OS1.Range("C7") = "" Or OS1.Range("C11") = "" Then 'condition : si le numéro de lot et/ou la date ne sont pas renseignés
        OS1.Activate 'active l'onglet OS1 (="LOT")
        OS1.Range("C7").Select 'sélectionne la cellue C7
        MsgBox "Vous devez renseigner le numéro de lot et la date !" 'message
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
    DEST.Value = OS1.Range("C11").Value 'récupère la date
    DEST.Offset(0, 1).Value = Target.Value 'récupère le type de nom conformité
    DEST.Offset(0, 2).Value = OS1.Range("C7").Value 'récupère le numéro de lot
'tu peux éventuellement fermer le classeur destination avec : CD.Close SaveChanges:=True
End If

'ecriture automatique date
On Error Resume Next
If Not Intersect(Target, [I19:O19,I76:O76,I133:O133,I190:O190,I247:O247]) Is Nothing Then ' cellule de saisie
    Target(2, 1) = Now  'le premier chiffre c'est le numero de ligne et le  deuxieme c'est la colone
End If
'bloquer cellules apres saisie
If Not Intersect(Target, Range("A19:O50,A52:O107,A109:O164,A166:O221,A223:O278,A280:O288")) Is Nothing Then
    Target.Locked = True
'code signature electronique...................................................
ElseIf Not Application.Intersect(Target, Range("I51:O51,I108:O108,I165:O165,I222:O222,I279:O279")) Is Nothing Then
    If Target = Empty Then
        'efface commentaire
        Target.ClearComments
    Else
    'recherche si Initiales existe
    With Worksheets("paramètre")
        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        Set Col_A = .Range("A41:A" & derlig)
        If Application.CountIf(Col_A, Target) <> 1 Then
            MsgBox "N'existe pas!!!!!!"
            Exit Sub
        Else
            lig = 1
            lig = .Columns(1).Find(Target, .Cells(lig, 1), , xlWhole).Row
            TPass = .Range("C" & lig)
            'appel UF Mot de passe
            UF_PassWord.Lbl_Operateur = .Range("B" & lig)
            Operateur = .Range("B" & lig)
        End If
    End With
    UF_PassWord.Show
    If TPass = -1 Then
    Else
        Application.EnableEvents = False
        Application.Undo
    End If
End If
Target.Locked = True 'bloquer cellule signature electronique
' fin code signature electronique..............................................
End If
Application.EnableEvents = True
End Sub