Sujet Précédent Sujet Suivant

MYDATA.application

Fermé
PIERRE - 10 mai 2017 à 19:56
f894009 Messages postés 17205 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 19 octobre 2024 - 11 mai 2017 à 08:00
Bonsoir,ce code ne marche pas, problème MyData = Application.InputBox("Entrez donnée à chercher, valeur alphanumérique") peut être,si vous pouvez m'aidez sur ce code merci.

Sub Transfert_Prod()
'
' Transfert_Prod Macro
'

'
Workbooks.Open Filename:="C:\Users\jmorante\Desktop\Gestion Production L03\MMS686PF"


ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
Columns("X:X").Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste

Columns("W:W").Select
Selection.TextToColumns Destination:=Range("W1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(9, 1), Array(16, 1), Array(21, 1)), _
TrailingMinusNumbers:=True
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
Columns("X:AP").Select
Selection.Delete Shift:=xlToLeft
Range("V16").Select
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1



Dim Lig1 As Long, Derlig1 As Long, Derlig2 As Long, Cp As Variant
Dim Lig2 As Long

Dim Plage As Range
Dim MyFile As Variant
MyData = Application.InputBox("Entrez donnée à chercher, valeur alphanumérique")
Dim NbLignes
NbLignes = ActiveSheet.UsedRange.Rows.Count
Set Plage = Worksheets("MMS686PF").Range("W1:W" & NbLignes)

Sheets.Add
ActiveSheet.Name = "Recherche_Réf"

Worksheets("MMS686PF").Range("A1:W1").Copy
Sheets("Recherche_Réf").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1:W1").font.Bold = True

For Each Cell In Plage
If MyData = Cell.Value Then

Cell.Interior.ColorIndex = 6
Cell.EntireRow.Copy
Worksheets("Recherche_Réf").Select
Cells(65999, 1).End(xlUp)(2).Select
ActiveSheet.Paste
Else
If MyData = Empty Then
MsgBox "Aucune Valeur rentrée, essayez à nouveau ou fin"
ActiveWorkbook.Close SaveChanges:=False
Exit Sub
End If
End If
Next Cell



Worksheets("Recherche_Réf").Select
Range("B79").Activate
ActiveSheet.Range("$A$1:$W$" & NbLignes).RemoveDuplicates Columns:=3, Header:=xlYes
ActiveWindow.SmallScroll Down:=-84
Range("F:L").Delete
Cells.Select
Cells.EntireColumn.AutoFit





Derlig1 = Sheets("Recherche_Réf").Range("D65535").End(xlUp).Row
Derlig2 = Sheets("MMS686PF").Range("D65535:W65535").End(xlUp).Row


With Sheets("MMS686PF")
For Lig1 = 2 To Derlig1
Cp = Sheets("Recherche_Réf").Cells(Lig1, "D")
For Lig2 = 2 To Derlig2
If Cp = .Cells(Lig2, "D") And .Cells(Lig2, "W") = "L01=>L03" Then

Sheets("Recherche_Réf").Cells(Lig1, "Q").Value = "L01=>L03"
Sheets("Recherche_Réf").Cells(Lig1, "Q").Interior.ColorIndex = 19
Else

If Cp = .Cells(Lig2, "D") And .Cells(Lig2, "R") = "251" Then

Sheets("Recherche_Réf").Cells(Lig1, "Q").Value = "Cde en cours"
Sheets("Recherche_Réf").Cells(Lig1, "Q").Interior.ColorIndex = 44

End If

End If
Next Lig2
Next Lig1
End With


With Sheets("MMS686PF")
For Lig1 = 2 To Derlig1
Cp = Sheets("Recherche_Réf").Cells(Lig1, "D")
For Lig2 = 2 To Derlig2
If Cp = .Cells(Lig2, "D") And .Cells(Lig2, "R") = "101" Then

Sheets("Recherche_Réf").Cells(Lig1, "Q").Value = "Ordre de Fab."
Sheets("Recherche_Réf").Cells(Lig1, "Q").Interior.ColorIndex = 8

End If
Next Lig2
Next Lig1
End With



Sheets.Add
ActiveSheet.Name = "Commandes & OF_" & MyData
Worksheets("MMS686PF").Range("A1:W1").Copy
Sheets("Commandes & OF_" & MyData).Select
Range("A1").Select
ActiveSheet.Paste
Range("A1:W1").font.Bold = True


With Sheets("MMS686PF")
For Lig1 = 2 To Derlig1
Cp = Sheets("Recherche_Réf").Cells(Lig1, "D")
For Lig2 = 2 To Derlig2
If Cp = .Cells(Lig2, "D") And .Cells(Lig2, "R") = "251" Or Cp = .Cells(Lig2, "D") And .Cells(Lig2, "R") = "101" Then

.Cells(Lig2, "D").EntireRow.Copy
Worksheets("Commandes & OF_" & MyData).Select
Cells(65999, 1).End(xlUp)(2).Select
ActiveSheet.Paste

End If
Next Lig2
Next Lig1
End With



Range("F:L").Delete
Cells.Select
Cells.EntireColumn.AutoFit

NbLignes = ActiveSheet.UsedRange.Rows.Count
Set Plage = Worksheets("Commandes & OF_" & MyData).Range("K2:K" & NbLignes)

For Each Cell In Plage
If Cell.Value = 251 Then
Cell.Interior.ColorIndex = 44
Else
Cell.Interior.ColorIndex = 8
End If
Next Cell

Range("A1").Select

End Sub

2 réponses

Réponse 1 / 2
aurelie76 Messages postés 88 Date d'inscription samedi 19 avril 2008 Statut Membre Dernière intervention 13 mai 2017 3
10 mai 2017 à 22:31
bonsoir,

lu vite fait, n'y a -t-il pas une erreur dans le script à la place de la déclaration 


Dim Plage As Range
Dim MyFile As Variant
MyData = Application.InputBox("Entrez donnée à chercher, valeur alphanumérique")


MyData n'est pas déclaré et MyFile n'apparait nul part sauf en déclaration et application.inputbox -> inputbox suffit

essayer ceci : 

Dim Plage As Range
Dim MyData As Variant
MyData = InputBox("Entrez donnée à chercher, valeur alphanumérique")
0
Réponse 2 / 2
f894009 Messages postés 17205 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 19 octobre 2024 1 709
Modifié le 11 mai 2017 à 08:00
Bonjour a vous deux,
aurelie76:

application.inputbox -> inputbox suffit
Oui et non a la fois, 
MyData = Application.InputBox("Entrez donnée à chercher, valeur alphanumérique") 
ou
MyData = InputBox("Entrez donnée à chercher, valeur alphanumérique")

dans les deux cas le resultat est une chaine de caractere donc pour tester avec du numerique ca ne va pas 
For Each Cell In Plage
If MyData = Cell.Value Then

Il faut une conversion de MyData en numerique
Avec Application.InputBox c'est parametrable et traitement d'erreur inclus

PIERRE: code modifie 
MyData = Application.InputBox("valeur alphanumérique", "Entrez donnée à chercher", , , , , , Type:=1)


Voir ceci entre autre pour plus de details
https://www.excel-plus.fr/vba/demvba/msgbox-inputbox-et-application-inputbox/
0