Microsoft 365 Transférer les données entrées dans un userform d'un classeur et les transférer dans les cellules d'un autre classeur

Arch974

XLDnaute Junior
Bonjour,

J'ai un classeur "Détail" qui contient un userform et je souhaite que lorsque j'entre mes données celles-ci et le résultat du prix calculer apparaissent dans les cellules d'un autre classeur "Devis" en ouvrant les fichiers ça sera plus clair.

Merci d'avance.
 

Pièces jointes

  • Détail.xlsm
    23.2 KB · Affichages: 11
  • devis.xlsx
    9.6 KB · Affichages: 6
Solution
Bonjour Arch974, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Le code de l'UserForm :
VB:
Private Sub CommandButton1_Click()
Dim chemin$, fichier$, v#, lig&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "devis.xlsx") 'nom à adapter
If fichier = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown: Exit Sub
v = Val(Replace(tb_Qte, ",", ".")): tb_Qte = v
If v <= 0 Then tb_Qte = "": tb_Qte.SetFocus: Exit Sub
Application.ScreenUpdating = False
With Workbooks.Open(chemin & fichier).Sheets(1) 'ouvre le fichier
    lig = .[A1].CurrentRegion.Rows.Count + 1
    .Cells(lig, 1) = cb_CIT
    .Cells(lig...

job75

XLDnaute Barbatruc
Bonjour Arch974, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Le code de l'UserForm :
VB:
Private Sub CommandButton1_Click()
Dim chemin$, fichier$, v#, lig&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "devis.xlsx") 'nom à adapter
If fichier = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown: Exit Sub
v = Val(Replace(tb_Qte, ",", ".")): tb_Qte = v
If v <= 0 Then tb_Qte = "": tb_Qte.SetFocus: Exit Sub
Application.ScreenUpdating = False
With Workbooks.Open(chemin & fichier).Sheets(1) 'ouvre le fichier
    lig = .[A1].CurrentRegion.Rows.Count + 1
    .Cells(lig, 1) = cb_CIT
    .Cells(lig, 2) = v
    .Cells(lig, 4) = Val(Replace(tb_Prix, ",", "."))
    .Cells(lig, 3) = .Cells(lig, 4) / v
    .Parent.Close True 'enregistre et ferme le fichier
End With
MsgBox "Le fichier '" & fichier & "' a été mis à jour"
End Sub

Private Sub CommandButton2_Click()
cb_CIT = ""
tb_Qte = ""
tb_Prix = ""
End Sub

Private Sub tb_Qte_Change()
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown _
    Else tb_Prix = Val(Replace(tb_Qte, ",", ".")) * Range("H" & cb_CIT.ListIndex + 2)
End Sub

Private Sub UserForm_Initialize()
Dim fin&, i&
With Sheets("Detail-Revetement")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne
    For i = 2 To fin 'on charge le combo CIT avec les elements de la colonne A
        cb_CIT.AddItem .Range("A" & i)
    Next i
End With
End Sub
A+
 

Pièces jointes

  • Détail(1).xlsm
    29.1 KB · Affichages: 3
  • devis.xlsx
    9.5 KB · Affichages: 4

Arch974

XLDnaute Junior
Bonjour Arch974, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Le code de l'UserForm :
VB:
Private Sub CommandButton1_Click()
Dim chemin$, fichier$, v#, lig&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "devis.xlsx") 'nom à adapter
If fichier = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown: Exit Sub
v = Val(Replace(tb_Qte, ",", ".")): tb_Qte = v
If v <= 0 Then tb_Qte = "": tb_Qte.SetFocus: Exit Sub
Application.ScreenUpdating = False
With Workbooks.Open(chemin & fichier).Sheets(1) 'ouvre le fichier
    lig = .[A1].CurrentRegion.Rows.Count + 1
    .Cells(lig, 1) = cb_CIT
    .Cells(lig, 2) = v
    .Cells(lig, 4) = Val(Replace(tb_Prix, ",", "."))
    .Cells(lig, 3) = .Cells(lig, 4) / v
    .Parent.Close True 'enregistre et ferme le fichier
End With
MsgBox "Le fichier '" & fichier & "' a été mis à jour"
End Sub

Private Sub CommandButton2_Click()
cb_CIT = ""
tb_Qte = ""
tb_Prix = ""
End Sub

Private Sub tb_Qte_Change()
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown _
    Else tb_Prix = Val(Replace(tb_Qte, ",", ".")) * Range("H" & cb_CIT.ListIndex + 2)
End Sub

Private Sub UserForm_Initialize()
Dim fin&, i&
With Sheets("Detail-Revetement")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne
    For i = 2 To fin 'on charge le combo CIT avec les elements de la colonne A
        cb_CIT.AddItem .Range("A" & i)
    Next i
End With
End Sub
A+
Merci beaucoup ça fonctionne du tonnerre.
 

Arch974

XLDnaute Junior
Bonjour Arch974, le forum,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Le code de l'UserForm :
VB:
Private Sub CommandButton1_Click()
Dim chemin$, fichier$, v#, lig&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "devis.xlsx") 'nom à adapter
If fichier = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown: Exit Sub
v = Val(Replace(tb_Qte, ",", ".")): tb_Qte = v
If v <= 0 Then tb_Qte = "": tb_Qte.SetFocus: Exit Sub
Application.ScreenUpdating = False
With Workbooks.Open(chemin & fichier).Sheets(1) 'ouvre le fichier
    lig = .[A1].CurrentRegion.Rows.Count + 1
    .Cells(lig, 1) = cb_CIT
    .Cells(lig, 2) = v
    .Cells(lig, 4) = Val(Replace(tb_Prix, ",", "."))
    .Cells(lig, 3) = .Cells(lig, 4) / v
    .Parent.Close True 'enregistre et ferme le fichier
End With
MsgBox "Le fichier '" & fichier & "' a été mis à jour"
End Sub

Private Sub CommandButton2_Click()
cb_CIT = ""
tb_Qte = ""
tb_Prix = ""
End Sub

Private Sub tb_Qte_Change()
If cb_CIT.ListIndex = -1 Then CommandButton2_Click: cb_CIT.DropDown _
    Else tb_Prix = Val(Replace(tb_Qte, ",", ".")) * Range("H" & cb_CIT.ListIndex + 2)
End Sub

Private Sub UserForm_Initialize()
Dim fin&, i&
With Sheets("Detail-Revetement")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne
    For i = 2 To fin 'on charge le combo CIT avec les elements de la colonne A
        cb_CIT.AddItem .Range("A" & i)
    Next i
End With
End Sub
A+
le seul hic c'est que ça referme à chaque fois le classeur "Devis" quand on envoi les valeurs.
 

Discussions similaires