Transfert de données sous conditions

Bonjour à tous,

J'ai un problème qui dépasse mes compétences sur un fichier contenant de nombreuses macro.

Je viens vous demander de l'aide et en connaitre la faisabilité car mon supérieur désire que je le réalise et là je sèche complet.

Je vous livre deux fichiers pour avoir une meilleure compréhension du problème :

Un fichier source .xlsm qui comporte sur le fichier réel de nombreux onglets mais dont je ne récupère que certaines données sur un onglet.

Un fichier destination qui est la structure exacte qui doit accueillir les données transférées.

En clair, je dois créer sur le fichier source un bouton sur l'onglet désiré qui lorsque je clique dessus, va faire les choses suivantes:

• ouvrir le fichier destination vierge
• Copier certaines donnée a compter de la ligne 15
• Choix des donnée en fonction du niveau (croix dans colonne P ou Q uniquement)
• Si Pou Q avec une croix alors copier les donnée de E et I et uniquement celles qui ont une croix en E ou I
• Recopier les données copiées en dans les bonnes cases en fonction de critères a compter de la ligne 9
• Recopier dans destination la donnée E écrite en noir dans des la colonne A
• Recopier dans la destination la donnée E écrite en bleu dans la colonne B
• Recopier dans la destination la donnée I dans la colonne D

J'ai essayé de vous montrer le résultat dans le fichier destination pour que cela soit plus simple a comprendre.

Pensez vous que cela soit réalisable avec du VBA et un bouton relié a une macro?

Pouvez vous m'aider car là je sèche complètement?

Merci pour votre aide

Bonjour,

En supposant que le fichier "Source" et le fichier "Destination" soient dans le même répertoire:

Le code

Option Explicit

Sub Transfert()
    Dim w1 As Workbook, w2 As Workbook
    Dim f1 As Worksheet, f2 As Worksheet
    Dim i As Long, DerLig_w1 As Long, DerLig_w2 As Long, Deb As Long, Col As Long
    Dim Chemin As String
    Dim Texte1, Texte2, Texte3
    Dim X As Object

    Application.ScreenUpdating = False
    Set w1 = ThisWorkbook
    Chemin = ThisWorkbook.Path & "\"
    Workbooks.Open Filename:=Chemin & "destination.xlsx"
    Set w2 = ActiveWorkbook
    Set f2 = Sheets("Checklist Document")
    DerLig_w2 = f2.Range("A" & Rows.Count).End(xlUp).Row

    w1.Activate
    Set f1 = Sheets("2- Questionnaire")
    DerLig_w1 = f1.Range("E" & Rows.Count).End(xlUp).Row
    With f1.Range("P14:Q" & DerLig_w1)
        Set X = .Find("X")
        If Not X Is Nothing Then
            Deb = X.Row
            Col = X.Column
            Do
                If f1.Cells(X.Row, Col).MergeCells Then
                    Texte1 = f1.Cells(X.Row, "E")
                    Texte2 = f1.Cells(X.Row + 1, "E")
                    Texte3 = f1.Cells(X.Row, "I")
                    w2.Activate
                    Range(f2.Cells(DerLig_w2 + 1, "A"), f2.Cells(DerLig_w2 + 1, "D")).Value = Array(Texte1, Texte2, "", Texte3)
                    DerLig_w2 = DerLig_w2 + 1
                Else
                    Texte1 = f1.Cells(X.Row, "E")
                    Texte3 = f1.Cells(X.Row, "I")
                    w2.Activate
                    Range(f2.Cells(DerLig_w2 + 1, "A"), f2.Cells(DerLig_w2 + 1, "D")).Value = Array(Texte1, "", "", Texte3)
                    DerLig_w2 = DerLig_w2 + 1
                End If
                w1.Activate
                Set X = .FindNext(X)
            Loop While Not X Is Nothing And X.Row <> Deb
        End If
    End With
    w2.Activate
    f2.Range("B2:B" & DerLig_w2).Font.Color = RGB(0, 0, 255)
    w2.Close
    Set w1 = Nothing
    Set w2 = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set X = Nothing
End Sub

Cdlt

Bonjour,

Effectivement, c'est dans le meme répertoire.

Je vais faire la modification de code dans la journée et tester la solution.

Merci infiniment

Merci Merci Merci

cela marche parfaitement

J'ai juste oublié un détail

Il faut en même temps copier dans la feuille 1-Synthèse et Résultat copier la case AB17

et la coller dans le fichier destination en C1

Puis dans destination si un commentaire a été collé, il faut inscrire Non Conforme dans la colonne C

Ce serait formidable

J'ai complété le VBA pour ma nouvelle question donc côté code tout fonctionne et c'est merveilleux.

Un grand merci pour la solution et surtout cette vision claire.

Merci a tous ceux qui ont regardé le message et essayé de trouver une solution