Macro pour selectionner dans une database
Bonjour à vous les excellents
j'ai un nouveau projet pro qui mobilise des compétence que je n'ai pas (pas encore)
dans la maquette que je met en pièce joint il y a un onglet template que l'utilisateur remplis
1-faire une macro qui stock les data dans une database-> ca ok je sais faire
2-faire une macro qui
1-via une liste "Secteur" (nb d'éléments fixe)
2-donne accès a une liste "titre" (nb d'élément constamment augmenté); pour ne pas avoir tout les titres de tous les secteurs d'un coup
3-une fois le titre sélectionné renvoie dans les champs du template (colone c dans l'exemple) les champs correspondant au titre choisi
->ca je ne sais pas faire, en parcourant le forum j'ai compris qu'il fallait gérer un user form (ce que je n'arrive pas a faire malgré le cour qui semble pourtant claire) dans lequel on aurait une liste box (mais que je ne voir pas comment préremplir)
3-faire une macro qui permet de mettre a jour une fois 2 fait ->ca je sais faire
4-envoyer a une mailing list prédéfinis-> en principe je sais faire
si vous pouvierz m'aider sur le point 2 c'est cool
Hello,
Classeur vide ???
oui en effet
Hello,
Je ne comprend pourquoi vous voulez faire compliqué quand on peut faire simple ...
A moins que je n'ai pas bien saisi ...
Je dirai même que vba ne sert pas à grand chose dans l'exemple que vous avez envoyé...
En tout cas j'ai coder qqch :)
Pour moi :
2 listes déroulante dans template
une liste suplementaire dans liste (celle des titre ==> rafraichie automatiquement)
+ 4 recherchev dans template pour champs 1 2 3 4 et basta !!!! rien de +
@Rag oui ça c'est si j'avais le droit de mettre une formule dans ma cellule... sauf que la les cellules d'entree de donnée et d'affichage sont les memes
typiquement avec votre proposition, si j'essaye de rentrer tata4:
Hello,
Ce n'est pas ici qu'il faut ajouter une valeur titre.
Comme je disais au dessus
une liste suplementaire dans liste (celle des titre ==> rafraichie automatiquement)
c'est dans la feuille liste, à la première ligne vide de la colonne B
Bonjour j'ai avancé sur mon projet
je vais le tester avec ma hiérarchie vendredi
en gros ça marche mais il y a toujours c'est histoire de liste déroulante que je n'ai pas et que je souhaiterais améliorer
cijoint nouvelle maquette
et mon code VBA (ne manque que qq fonctions a l'ouverture du classeur)
la zone a améliorrer
Sub loadold()
Dim k, z, aa As Integer
Dim j As String
z = 0
j = InputBox("saisir N° de SO-PSC")ou je voudrais une liste de tous les titres possible pour un atelier donné au lieu de devoir rentré manuellement le code exacte du titre (bref remplace l'input box au profit d'un userform)
code complet
Dim i As Integer
Sub Clear()
Sheets("SO-PSC").Unprotect
Sheets("SO-PSC").Range("C3:J4").ClearContents
Sheets("SO-PSC").Range("A6").ClearContents
Sheets("SO-PSC").Range("E10:K27").ClearContents
Sheets("SO-PSC").Range("A31:K42").ClearContents
Sheets("SO-PSC").Range("A47:K56").ClearContents
Sheets("SO-PSC").Protect
End Sub
Sub load_substepcopypaste()
Application.ScreenUpdating = False
Sheets("SO-PSC").Unprotect
Sheets("Listes").Visible = True
Sheets("Database").Visible = True
Sheets("SO-PSC").Range("C3").Copy
Sheets("Database").Range("B" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("E10:E27").Copy
Sheets("Database").Range("C" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("A31:A42").Copy
Sheets("Database").Range("U" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("A47:A56").Copy
Sheets("Database").Range("V" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("I47:I56").Copy
Sheets("Database").Range("AF" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("J47:J56").Copy
Sheets("Database").Range("AP" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("L47:L56").Copy
Sheets("Database").Range("AZ" & i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Database").Range("A" & i) = Left(Sheets("Database").Range("F" & i).Value, 3) & "-" & i
Sheets("SO-PSC").Protect
Application.ScreenUpdating = True
Sheets("Listes").Visible = False
Sheets("Database").Visible = False
Sheets("SO-PSC").Activate
End Sub
Sub loadold()
Dim k, z, aa As Integer
Dim j As String
z = 0
j = InputBox("saisir N° de SO-PSC")
Application.ScreenUpdating = False
Sheets("SO-PSC").Unprotect
Sheets("Listes").Visible = True
Sheets("Database").Visible = True
Sheets("Database").Activate
k = Range("A" & Rows.Count).End(xlUp).Row + 1
On Error GoTo 1
i = Application.Match(j, Range("A2:A" & k), 0) + 1
z = 1
1
If z = 0 Then
MsgBox "merci de rentrer un item existant"
Sheets("SO-PSC").Activate
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 2
aa = 1
Sheets("SO-PSC").Range("C3:J4").UnMerge
Sheets("Database").Range("B" & i).Copy
Sheets("SO-PSC").Range("C3").PasteSpecial Paste:=xlPasteValues
Sheets("SO-PSC").Range("C3:J4").Merge
Sheets("SO-PSC").Range("E10:K27").UnMerge
Sheets("Database").Range("C" & i & ":T" & i).Copy
Sheets("SO-PSC").Range("E10").PasteSpecial Paste:=xlPasteValues, Transpose:=True
For z = 10 To 27
Sheets("SO-PSC").Range("E" & z & ":K" & z).Merge
Next
Sheets("SO-PSC").Range("A31:K42").UnMerge
Sheets("Database").Range("U" & i).Copy
Sheets("SO-PSC").Range("A31").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Range("A31:K42").Merge
Sheets("SO-PSC").Range("A47:G56").UnMerge
Sheets("Database").Range("V" & i & ":AE" & i).Copy
Sheets("SO-PSC").Range("A47").PasteSpecial Paste:=xlPasteValues, Transpose:=True
For z = 47 To 56
Sheets("SO-PSC").Range("A" & z & ":G" & z).Merge
Next
Sheets("Database").Range("AF" & i & ":AO" & i).Copy
Sheets("SO-PSC").Range("I47").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Database").Range("AP" & i & ":AY" & i).Copy
Sheets("SO-PSC").Range("J47").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Database").Range("AZ" & i & ":BI" & i).Copy
Sheets("SO-PSC").Range("K47").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Database").Range("A" & i).Copy
Sheets("SO-PSC").Range("A6").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("SO-PSC").Activate
2
If aa = 0 Then
MsgBox "la macro a terminé sans s'effectuer suite à une erreure"
Sheets("SO-PSC").Activate
Application.ScreenUpdating = True
Exit Sub
End If
Sheets("SO-PSC").Protect
Sheets("Listes").Visible = False
Sheets("Database").Visible = False
Application.ScreenUpdating = False
End Sub
Sub loadnew()
Dim k, z, aa As Integer
Application.ScreenUpdating = False
Sheets("SO-PSC").Unprotect
Sheets("Listes").Visible = True
Sheets("Database").Visible = True
For k = 10 To 16
If Sheets("SO-PSC").Range("E" & k) = "" Then
MsgBox "Merci de remplir tous les champs de la partie 'Création'"
Exit Sub
End If
Next
If Sheets("SO-PSC").Range("C3") = "" Then
MsgBox "Merci de remplir le champ Titre (cellule C3:J4)"
Exit Sub
End If
If Sheets("SO-PSC").Range("A6") <> "" Then
MsgBox "Un So-PSC avec ce n° existe déja, privilégier 'Mettre a jour le SO-PSC existant affiché'"
Exit Sub
End If
Sheets("Database").Activate
i = Range("B" & Rows.Count).End(xlUp).Row + 1
Call load_substepcopypaste
Sheets("Database").Range("BJ" & i) = 1
Sheets("Database").Range("BK" & i) = Application.VLookup(Sheets("Database").Range("C" & i), Sheets("Listes").Range("X2:Y9"), 2, 0)
Sheets("SO-PSC").Unprotect
Sheets("SO-PSC").Range("A6") = Sheets("Database").Range("A" & i).Value
Sheets("SO-PSC").Activate
Call mail_outlook_
Sheets("SO-PSC").Protect
Sheets("Listes").Visible = False
Sheets("Database").Visible = False
Application.ScreenUpdating = True
End Sub
Sub updateold()
Dim j As String
Application.ScreenUpdating = False
Sheets("SO-PSC").Unprotect
Sheets("Listes").Visible = True
Sheets("Database").Visible = True
j = Sheets("SO-PSC").Range("A6")
Sheets("Database").Activate
k = Range("A" & Rows.Count).End(xlUp).Row + 1
i = Application.Match(j, Range("A2:A" & k), 0) + 1
Call load_substepcopypaste
Sheets("SO-PSC").Activate
If Range("E17") <> "" Then
If Range("E19") <> "" Then
Sheets("Database").Range("BJ" & i) = 2
Else: MsgBox "merci de remplir la date d'approbation"
Exit Sub
End If
If Range("E22") = "OK" And Range("E22") = "OK" Then
Sheets("Database").Range("BJ" & i) = 3
If Range("E24") <> "" Then
Sheets("Database").Range("BJ" & i) = 4
If Range("E25") <> "" Then
Sheets("Database").Range("BJ" & i) = 5
If Range("E26") <> "" Then
If Range("E27") <> "" Then
Sheets("Database").Range("BJ" & i) = 2
Else: MsgBox "merci de remplir la date de validation"
Exit Sub
End If
End If
End If
End If
Else
Sheets("Database").Range("BJ" & i) = 2
End If
Else: Sheets("Database").Range("BJ" & i) = 1
End If
Sheets("Listes").Range("T26") = Sheets("Database").Range("BJ" & i).Value
Sheets("Listes").Range("S37") = Sheets("Database").Range("F" & i).Value
Sheets("SO-PSC").Activate
If MsgBox("Etes-vous certain de vouloir envoyer ce SP-PSC par Mail ?", vbYesNo, "Demande de confirmation") = vbYes Then
Call mail_outlook_
Else: MsgBox "Retour à la modification"
End If
Sheets("SO-PSC").Unprotect
Sheets("Listes").Visible = False
Sheets("Database").Visible = False
Application.ScreenUpdating = True
End Sub
Sub mail_outlook_()
Dim OutApp As Object 'Déclaration de l'application objet Outlook
Dim OutMail As Object 'Déclaration du mail objet Outlook
Dim current_type, current_item As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'préparation des paramètres
Sheets("Listes").Visible = True
Sheets("Database").Visible = True
i = 2
Sheets("Listes").Range("S26") = Sheets("Database").Range("F" & i).Value
Sheets("Listes").Range("S37") = Sheets("Database").Range("BJ" & i).Value
Sheets("Listes").Range("S48") = Sheets("Database").Range("C" & i).Value
Sheets("Listes").Range("S51") = Sheets("Database").Range("B" & i).Value
Sheets("Listes").Range("U51") = Sheets("Database").Range("A" & i).Value
current_type = Sheets("Listes").Range("S45").Value
current_item = Sheets("Listes").Range("U51").Value
With OutMail
.To = Worksheets("Listes").Range("T54") 'va cherche la valeur dans le cellule B1 de la feuille "mail"
.CC = Worksheets("Listes").Range("T57") 'va cherche la valeur dans le cellule B1 de la feuille "mail"
.BCC = ""
.Subject = Worksheets("Listes").Range("X45") & " SO-PSC " & Worksheets("Listes").Range("U51")
' séparer deux valeurs par un &
' le texte écrit 'en dur' doit toujours être entouré de ""
' & Time() & propID permet d'avoir l'heure de création du mail
.HTMLBody = "Bonjour, vous avez un nouveau SO-PSC à " & current_type & "<br><br>" & _
"Son numéro est: " & "<br>" & _
"<FONT COLOR=Green>" & current_item & "</FONT>" & "<br><br>" & _
"Vous le retrouverez au lien hypertexte suivant: " & "<br>" & _
"<a href=\\10.4.162.82\Services\Unit%20SPI%20-%20Quality%20and%20Engineering\Stop%20order%20et%20prod%20sous%20surveillance%20order>par ici...</a>" & "<br>" & _
.HTMLBody
' ajouter & vbCrLf & pour aller à la ligne entre deux valeurs
' .Attachments.Add ActiveWorkbook.FullName 'Ajoute en pièce-jointe le classeur actif
'.Attachments.Add "C:\MonDossier\MonFichier.xlsx" 'Ajouter une pièce-jointe à ton mail, indique le chemin complet au fichier que tu veux attacher
.Display 'affiche le mail en brouillon dans Outlook, pratique
'pour vérifier avant d'envoyer
'.Send 'envoie directement le mail
'.Save 'sauvegarde le mail
End With
Set OutMail = Nothing 'nettoie la mémoire en nettoyant les variables
Set OutApp = Nothing 'nettoie la mémoire en nettoyant les variables
Sheets("Listes").Visible = False
Sheets("Database").Visible = False
End Sub