Mydata inputbox
Résolu
PIERRE
-
PIERRE -
PIERRE -
Bonjour,
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. Je vous remercie pour votre aide hier ,mais les 2 codes que vous m'avez proposé ne marche pas .Je continue de chercher.
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
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. Je vous remercie pour votre aide hier ,mais les 2 codes que vous m'avez proposé ne marche pas .Je continue de chercher.
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
3 réponses
Bonjour,
Vous dites que ce qui est propose ici:
MYDATA.application
PIERRE - 10 mai 2017 à 19:56 - Dernière réponse le 11 mai 2017 à 08:00 par f894009
Ne marche pas, peut-etre(quoique...), mais si vous nous disiez ce qui ne marche pas genre erreur Excel ou autre(s)
Ne creez pas de nouvelle demande a chaque fois!
Vous dites que ce qui est propose ici:
MYDATA.application
PIERRE - 10 mai 2017 à 19:56 - Dernière réponse le 11 mai 2017 à 08:00 par f894009
Ne marche pas, peut-etre(quoique...), mais si vous nous disiez ce qui ne marche pas genre erreur Excel ou autre(s)
Ne creez pas de nouvelle demande a chaque fois!
bonjour merci pour votre réponse,mon problème est que la valeur (ex :L12300) entrée par l'utilisateur dans l'Inputbox n'est pas prise en compte et on passe directement au else if mydata =Empty et on sort du code Exit sub si cela peut vous aidez merci par avance.je ne comprend pas pourquoi?
Re,
Avec votre fichier, ce serait un peu plus simple pour vous repondre, fichier avec l'onglet MMS686PF evidemment
Pour transmettre un fichier,
Veillez a ce qu'il n'y ait PAS DE DONNEES CONFIDENTIELLES
il faut passer par un site de pièce jointe tel que cjoint.com
Allez sur ce site : https://www.cjoint.com/
Clic sur parcourir,
Cherche ton fichier,
clic sur ouvrir,
Clic sur "Créer le lien cjoint",
Copier le lien,
Revenir ici le coller dans une réponse...
Avec votre fichier, ce serait un peu plus simple pour vous repondre, fichier avec l'onglet MMS686PF evidemment
Pour transmettre un fichier,
Veillez a ce qu'il n'y ait PAS DE DONNEES CONFIDENTIELLES
il faut passer par un site de pièce jointe tel que cjoint.com
Allez sur ce site : https://www.cjoint.com/
Clic sur parcourir,
Cherche ton fichier,
clic sur ouvrir,
Clic sur "Créer le lien cjoint",
Copier le lien,
Revenir ici le coller dans une réponse...
je vous remercie pour votre aide,je pense avoir trouvé le problème en me servant de l'espion dans le débogage je me suis aperçu que la valeur dans l'inputbox était bien prise en compte mais cette valeur référence que l'on ma donné à chercher n'est pas dans la bonne colonne de la base de donnée,ce qui explique que je passais au Else c'est vraiment tout bête je vais pouvoir tester la semaine prochaine.MERCI ENCORE