XL 2016 VBA copier certaines cellules d un fichier à un autre sous conditions

[Fabien35200]

Bonjour


Je cherche à créer un code VBA me permettant de copier et coller certaines cellules d une base de données d un fichier A(classeur 1) vers un fichier B(classeur 2). Ces cellules seraient retranscrites si une case "ok" était validée.Toute la ligne ne serait pas recopiée mais seulement qqcellules de cette ligne.Et mon probleme le plus grand serait que si la ligne possède la case ok validé ,de retranscrire non pas en fonction du dossier principal mais en fonction de plusieurs sous dossiers rattachés à ce dossier.
Mon fichier initial est composé de plus de 500 lignes avec des données confidentielles, j ai donc refait 2 fichiers test pour expliquer ce que j aimerai (voir onglet resultat souhaité dans classeur 2).
Merci énormément par avance pour l aide reçu.

 

[Robert]

Bonjour Fabien, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim NCS As String 'déclare la variable NCS (Nom du Classeur Source)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("reception données") 'définit l'onglet destination OD
OD.Range("A2").CurrentRegion.Offset(1, 0).Clear 'supprime des éventuelles anciennes valeurs
CA = CD.Path & "\" 'définit le chemin d'accès CA (à adapter si le classeur ne se trouve pas dans le même dossier que le classeur CD)
NCS = "Classeur1.xlsx" 'définit le nom du classeur source (à adapter si le nom est différent)
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks(NCS) 'définit le classeur source (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Set CS = Workbooks.Open(CA & NCS) 'définit le classeur source en l'ouvrant
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreur
Set OS = CS.Worksheets("feuille de donnees") 'définit l'onglet source
TV = OS.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV
    If UCase(TV(I, 1)) = "OK" Then 'condition 1 : si la donnée ligne I colonne 1 de TV convertie en majuscules est égale à "OK"
        For J = 7 To 9 'boucle 12 sur les colonne 7 à 9 du tableau des valeurs TV (=> colonnes G à I)
            If TV(I, J) <> "" Then 'condition 2 : si la donné ligne I colonne J de TV n'est pas vide
                Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
                DEST.Value = TV(I, J) 'renvoie le sous dossier dans DEST
                DEST.Offset(0, 1).Value = TV(I, 2) 'renvoie l'affaire dans DEST décelée d'une colonne à droite
                DEST.Offset(0, 2).Value = TV(I, 3) 'renvoie le nom dans DEST décelée de deux colonnes à droite
                DEST.Offset(0, 3).Value = TV(I, 4) 'renvoie l'adresse dans DEST décelée de trois colonnes à droite
                DEST.Offset(0, 4).Value = TV(I, 6) 'renvoie la ville dans DEST décelée de quatres colonnes à droite
            End If 'fin de la condition 2
        Next J 'prochaine colonne de la boucle 2
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle 1
CS.Close False 'ferme le classeur source sans enregistrer
'quadrillage
With OD.Range("A2").CurrentRegion
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
End With
End Sub

Le ficher :

 

[Fabien35200]

Bonjour Robert,

Merci énormément pour ton aide.Je vais adapter ton code à mon fichier.
bien cordialement.

Fabien.