Transférer des données d'un fichier Excel à un autre

Le 12/07/2019 à 09:45

Bonjour à tous,

J'aurai besoin de votre aide pour un problème de transfère de données.

Dans le fichier "classeur1" je remplis les données, une fois les données remplies je souhaite les transférer en automatique dans le fichier "Fiche RPF" pour ensuite envoyer cette fiche à mon client.

Mon problème actuel est que mon code bug, je n'arrive pas à transférer les données, le worksheet bloque.

De plus, je souhaiterai (si possible), pouvoir si j'ai le même numéro de BL, mettre les "références/quantités et motifs" dans le tableau les uns sous les autres (Fiche RPF) et si j'ai un numéro de BL différent créer une nouvelle fiche.

Je ne sais pas si ma demande est très claire.

Je vous joins les deux fichiers que j'ai fait (ne pas faire attention à la mise en page je la ferai plus tard).

Je vous remercie beaucoup pour votre aide.

9classeur1.xlsm (21.01 Ko)
16fiche-rpf.xlsm (8.58 Ko)
Le 12/07/2019 à 10:22

Bonjour Claire, bonjour le forum,

Pour ton premier problème, peut-être comme ça :

Dim RPF As String
Dim Date1 As Date
Dim Agence As String
Dim BL As String
Dim Ref As String
Dim Qtt As String
Dim Motif As String
Dim wb As Workbook
Dim OD As Worksheet

'Récupération n° de ligne
numligne = ActiveCell.Row
RPF = Range("A" & numligne).Text
Date1 = Range("B" & numligne).Value
Agence = Range("C" & numligne).Text
BL = Range("D" & numligne).Text
Ref = Range("E" & numligne).Text
Qtt = Range("F" & numligne).Text
Motif = Range("G" & numligne).Text

'message de confirmation
rep = MsgBox("Voulez_vous créer la fiche " & RPF & " ? ", vbYesNo + vbQuestion, "Conformation")
If rep = vbNo Then
    MsgBox "Sélectionner une cellule de la ligne de RPF que vous souhaitez créer"
Else
    Set wb = Workbooks.Open("T:\02-Cestas AA1\M2-Qualite\Service_Qualite\Fiche RPF.xlsm")
    Set OD = wb.Worksheets(RPF) 'ou Set OD = wb.Worksheets("RPF") si nom et pas variable
    OD.Range("D5").Value = RPF
    OD.Range("E6").Value = Date1
    OD.Range("D7").Value = Agence
    OD.Range("E8").Value = BL
    OD.Range("C11").Value = Ref
    OD.Range("D11").Value = Qtt
    OD.Range("E11").Value = Motif
End If
End Sub
Le 12/07/2019 à 11:08

Bonjour Thauthème,

Merci beaucoup tu as résolu mon premier problème

Je continue à chercher pour la deuxième partie.

A plus,

Le 13/07/2019 à 15:11

Re,

Pas sûr d'avoir bien compris... Essais comme ça :

Private Sub CommandButton1_Click()
Dim TV As Variant 'délare la variable TV (Tableau des Valeurs)
Dim numligne As Integer 'délare la variable numligne
Dim RPF As String 'délare la variable RPF
Dim Date1 As Date 'délare la variable Date1
Dim Agence As String 'délare la variable Agence
Dim BL As String 'délare la variable BL
Dim NF As Integer 'délare la variable NF (Nombre de Fois)
Dim TL() As Variant 'délare la variable TL (Tableau des Lignes)
Dim K As Integer 'délare la variable K (incrément)
Dim I As Integer 'délare la variable I (Incrément)
Dim CD As Workbook 'délare la variable CD (classeur Destination)
Dim OD As Worksheet 'délare la variable OD (Onglet Destination)

TV = Range("A5").CurrentRegion 'définit la tableau des valeurs TV
numligne = ActiveCell.Row 'définit la variable numligne
RPF = Range("A" & numligne).Text 'définit la variable RPF
Date1 = Range("B" & numligne).Value 'définit la variable Date1
Agence = Range("C" & numligne).Text 'définit la variable Agence
BL = Range("D" & numligne).Text 'définit la variable BL
NF = Application.WorksheetFunction.CountIf(Columns(4), BL) 'définit le nombre de fois NF que le BL apparaît dans la colonne 4
ReDim Preserve TL(1 To 3, 1 To NF) 'redimensionne le tableau des lignes (3 lignes, NF colonnes)
K = 1 'initialise la variable K
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 4) = BL Then 'condition : si la donnée ligne I colonne 4 de TV est égale à BL
        TL(1, K) = TV(I, 5) 'récupère dans la ligne 1 de TL la donnée en colonne 5 de TV (=> transposition)
        TL(2, K) = TV(I, 6) 'récupère dans la ligne 2 de TL la donnée en colonne 6 de TV (=> transposition)
        TL(3, K) = TV(I, 7) 'récupère dans la ligne 3 de TL la donnée en colonne 7 de TV (=> transposition)
        K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
'condition 1 : si "Non" au message
If MsgBox("Voulez_vous créer la fiche " & RPF & " ? ", vbYesNo + vbQuestion, "Confirmation") = vbNo Then
    MsgBox "Sélectionner une cellule de la ligne de RPF que vous souhaitez créer" 'message
Else 'sinon
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set CD = Workbooks("Fiche RPF.xlsm") 'définit le classeur CD (génère une erreur si ce classeur n'est pas ouvert)
    If Err <> 0 Then 'condition 2 : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Set CD = Workbooks.Open("T:\02-Cestas AA1\M2-Qualite\Service_Qualite\Fiche RPF.xlsm") 'définit le classeur CD en l'ouvrant
    End If 'fin de la condition 2
    On Error GoTo 0 'annule la gestion des erreurs
    Set OD = CD.Worksheets(1) 'définit l'onglet de destination OD (le premier onglet du classeur CD)
    OD.Range("D5").Value = RPF 'renvoie [RPF] dans D5 de l'onglet OD
    OD.Range("E6").Value = Date1 'renvoie [Date1] dans E6 de l'onglet OD
    OD.Range("D7").Value = Agence 'renvoie [Agence] dans D7 de l'onglet OD
    OD.Range("E8").Value = BL 'renvoie [BL] dans E8 de l'onglet OD
    'renvoie dans C11 redimensionnée le tableau TL transposé
    OD.Range("C11").Resize(NF, 3).Value = Application.Transpose(TL)
End If 'fin de la condition 1
End Sub
Le 15/07/2019 à 14:58

Bonjour ThauTheme,

C'est merveilleux merci beaucoup ça marche très bien !!

Par contre si je peux me permettre une autre petite demande , Est-ce qu'il serait possible avant d'ouvrir mon fichier Fiche RPF, de supprimer les informations qui sont à l'intérieur ?

Imaginons ma première feuille RPF fait 3 lignes et ma seconde 2 lignes, j'aurai forcément ma 3eme ligne qui ne sera pas supprimée.

Merci beaucoup,

Claire

Le 16/07/2019 à 08:48

Re,

Le code modifié (désolé pour le retard) :

Private Sub CommandButton1_Click()
Dim TV As Variant 'délare la variable TV (Tableau des Valeurs)
Dim numligne As Integer 'délare la variable numligne
Dim RPF As String 'délare la variable RPF
Dim Date1 As Date 'délare la variable Date1
Dim Agence As String 'délare la variable Agence
Dim BL As String 'délare la variable BL
Dim NF As Integer 'délare la variable NF (Nombre de Fois)
Dim TL() As Variant 'délare la variable TL (Tableau des Lignes)
Dim K As Integer 'délare la variable K (incrément)
Dim I As Integer 'délare la variable I (Incrément)
Dim CD As Workbook 'délare la variable CD (classeur Destination)
Dim OD As Worksheet 'délare la variable OD (Onglet Destination)

TV = Range("A5").CurrentRegion 'définit la tableau des valeurs TV
numligne = ActiveCell.Row 'définit la variable numligne
RPF = Range("A" & numligne).Text 'définit la variable RPF
Date1 = Range("B" & numligne).Value 'définit la variable Date1
Agence = Range("C" & numligne).Text 'définit la variable Agence
BL = Range("D" & numligne).Text 'définit la variable BL
NF = Application.WorksheetFunction.CountIf(Columns(4), BL) 'définit le nombre de fois NF que le BL apparaît dans la colonne 4
ReDim Preserve TL(1 To 3, 1 To NF) 'redimensionne le tableau des lignes (3 lignes, NF colonnes)
K = 1 'initialise la variable K
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 4) = BL Then 'condition : si la donnée ligne I colonne 4 de TV est égale à BL
        TL(1, K) = TV(I, 5) 'récupère dans la ligne 1 de TL la donnée en colonne 5 de TV (=> transposition)
        TL(2, K) = TV(I, 6) 'récupère dans la ligne 2 de TL la donnée en colonne 6 de TV (=> transposition)
        TL(3, K) = TV(I, 7) 'récupère dans la ligne 3 de TL la donnée en colonne 7 de TV (=> transposition)
        K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
'condition 1 : si "Non" au message
If MsgBox("Voulez_vous créer la fiche " & RPF & " ? ", vbYesNo + vbQuestion, "Confirmation") = vbNo Then
    MsgBox "Sélectionner une cellule de la ligne de RPF que vous souhaitez créer" 'message
Else 'sinon
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set CD = Workbooks("Fiche RPF.xlsm") 'définit le classeur CD (génère une erreur si ce classeur n'est pas ouvert)
    If Err <> 0 Then 'condition 2 : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Set CD = Workbooks.Open("T:\02-Cestas AA1\M2-Qualite\Service_Qualite\Fiche RPF.xlsm") 'définit le classeur CD en l'ouvrant
    End If 'fin de la condition 2
    On Error GoTo 0 'annule la gestion des erreurs
    Set OD = CD.Worksheets(1) 'définit l'onglet de destination OD (le premier onglet du classeur CD)
    OD.Range("D5").Value = RPF 'renvoie [RPF] dans D5 de l'onglet OD
    OD.Range("E6").Value = Date1 'renvoie [Date1] dans E6 de l'onglet OD
    OD.Range("D7").Value = Agence 'renvoie [Agence] dans D7 de l'onglet OD
    OD.Range("D7").Value = OD.Range("E8").Value = BL 'renvoie [BL] dans E8 de l'onglet OD
    OD.Range("C10").CurrentRegion.Offset(1, 0).ClearContents 'efface d'éventuelles anciennes données
    'renvoie dans C11 redimensionnée le tableau TL transposé
    OD.Range("C11").Resize(NF, 3).Value = Application.Transpose(TL)
End If 'fin de la condition 1
End Sub
Le 16/07/2019 à 11:16

Re,

Merci beaucoup pour ton aide, ça fonctionne très bien.

Est-ce que je peux te demander un dernier petit service?

Suite à l'établissement de ma feuille RPF, je souhaiterai faire un mail automatique, mon code fonctionne très bien mais je souhaiterai pouvoir copier/coller mon tableau en entier en image sans devoir recopier ligne par ligne.

J'ai regardé sur le forum mais les codes que j'ai essayé ne fonctionnent pas.

5fiche-rpf.xlsm (19.53 Ko)
Le 16/07/2019 à 14:45

Re,

Arf ! sur ce coup là je ne pourrais pas t'aider . J'ai fais plusieurs tentative d'envoi d'email par VBA et je me suis toujours ramasée. Du coup j'ai laissé tombé cette possibilité.

Rechercher des sujets similaires à "transferer donnees fichier"