Option Explicit
Option Compare Text
Sub demander()
' DEFINITION DES VARIABLES QU'ON VA UTILISER
Dim extension As String
Dim chemin As String
Dim nomfichier As String
Dim cb1 As Variant, v As Range
Dim chem_fichier As String, wb As Workbook, wb_back As Workbook, wa As Workbook, NewFile As String
Dim mon_fichier As String, test As String, test_pdf As String
Dim entete As Range
Dim chem_pdf As String
Dim ext As String
Dim colonne As String
' PREPARATION DE LA VALEUR D'ENTRER (C'EST LA REFERENCE)*
cb1 = InputBox("Rentrer une valeur")
colonne = InputBox("Combien de produit devez-vous contrôler ?")
If colonne = "" Then
GoTo NothingFound_
End If
If IsNumeric(colonne) = False Then
GoTo NothingFound_
End If
If InStr(1, colonne, ",") Then
GoTo NothingFound_
End If
If InStr(1, colonne, "-") Then
GoTo NothingFound_
End If
If InStr(1, colonne, "_") Then
GoTo NothingFound_
End If
If InStr(1, colonne, ".") Then
GoTo NothingFound_
End If
' TEST POUR S'ASSURER QUE L'UTILISATEUR ENTRE UNE VALEUR
If cb1 = "" Then
GoTo NothingFound
End If
chem_pdf = "Z:\Industriel\Projets\Projet contrôle réception\"
ext = ".pdf"
test_pdf = Dir(chem_pdf & "Gamme_ctrl_" & cb1 & ".pdf")
' TEST POUR S'ASSURER QUE LA GAMME DE CONTROLE PDF EXISTE
If test_pdf <> "" Then
ActiveWorkbook.FollowHyperlink (chem_pdf & "Gamme_ctrl_" & cb1 & ".pdf")
Else
MsgBox ("fichier de contrôle de " & cb1 & " est introuvable")
End If
'DEFINITION DES ELEMENT NECESSAIRE AU TEST
Dim fso As Object, x As Boolean
chem_fichier = "Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\"
mon_fichier = cb1 & ".xlsm"
test = Dir(chem_fichier & mon_fichier)
Set fso = CreateObject("Scripting.FileSystemObject")
x = fso.FileExists(chem_fichier & mon_fichier)
' TEST POUR SAVOIR SI LE FICHIER DE CONTROLE RECEPTION ASSOCIE A LA REFERENCE EXISTE
If test <> "" Then
' On ouvre et on protège toutes les feuilles du classeur qu'on utilise */
Application.Workbooks.Open (chem_fichier & "\" & mon_fichier)
Sheets("reference").Visible = -1
Dim ab As Long
Dim i As Long
ab = ActiveWorkbook.Worksheets.Count
For i = 1 To ab
Sheets(i).Protect DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, Password:="test"
Next i
' On enleve la protection pour la feuille qu'on va utiliser
Sheets("reference").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Unprotect ("test")
'on renomme
ActiveSheet.Name = Format(Date, "dd mmm yyyy")
With ActiveSheet.Range("F12").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Format(Date, "dd mmm yyyy")
End With
'On insère nos colonnes
For i = 1 To colonne
ActiveSheet.Range("E1") = ("Mesures " & i)
ActiveSheet.Columns("E").Copy '.Insert Shift:=xlToLeft
ActiveSheet.Columns("E").Insert Shift:=xlToRight
Next
' Dim y As Long, z As Long
' For z = 5 To colonne
'For y = 2 To 7
' If Cells(y, z).Value < Cells(y, colonne + 1).Value And Cells(y, z).Value > Cells(y, colonne + 2).Value Then
' Cells(y, z).Interior.ColorIndex = 15
' End If
' Next y
' Next z
' On corrige l'erreur par défaut d'Excel manuellement
'ActiveSheet.Columns("E:E").Delete
'On rend la feuille "reference" invisible pour l'utilisateur
ActiveSheet.Buttons.Add(221.5, 492.25, 57.75, 12.75).Select
With Selection
.OnAction = "'Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\fiche_op.xlsm'!Feuil1.Imprimer"
.Characters.Text = "Validé contrôle"
.Font.Bold = True
End With
ActiveSheet.Buttons.Add(221.5, 572.25, 57.75, 12.75).Select
With Selection
.OnAction = "'Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\fiche_op.xlsm'!Feuil1.Imprimer"
.Characters.Text = "Non Conformité"
.Font.Bold = True
End With
Sheets("reference").Visible = 2
ActiveSheet.Columns("D").ColumnWidth = 20
ActiveWorkbook.Save
Else
' CREATION DU FICHIER DE CONTROLE SI IL N'EXISTE PAS
Set wb_back = Workbooks.Open(ThisWorkbook.Path & "\" & "tableau_controle.xlsm")
Set wb_back = ActiveWorkbook
extension = ".xlsm"
chemin = "Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\"
nomfichier = cb1 & extension
ActiveSheet.Range("B1:J1").Select
Selection.Copy
Set wb = Application.Workbooks.Add
Set wb = ActiveWorkbook
With ActiveWorkbook
Selection.Range("A1").PasteSpecial xlPasteFormats
Selection.Range("A1").PasteSpecial xlPasteAll
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
.SaveAs Filename:=chemin & "temporaire.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Set wb_back = Workbooks.Open(ThisWorkbook.Path & "\" & "tableau_controle.xlsm")
Set wb_back = ActiveWorkbook
' Ici commence la fonction de recherche
Dim FirstFound As String ' definition des variable que l'on va utiliser
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'Valeur a chercher cb1
Set myRange = ActiveSheet.UsedRange.Columns(2)
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=cb1, After:=LastCell, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Test pour voir si qlq chose est trouver
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
Application.Workbooks("temporaire.xlsm").Close
Kill (chemin & "temporaire.xlsm")
Workbooks("tableau_controle.xlsm").Close
GoTo NothingFound
End If
Set rng = FoundCell
' TEST POUR EMPECHER L'ERREUR SUR LA VALEUR TROUVEE
If rng <> cb1 Then
Application.Workbooks("temporaire.xlsm").Close
Kill (chemin & "temporaire.xlsm")
Workbooks("tableau_controle.xlsm").Close
GoTo NothingFound
Else
'Tour jusqu'a que ça trouve tout
Do Until FoundCell Is Nothing
'Trouve la nouvelle cellule avec la valeur
Set FoundCell = myRange.FindNext(After:=FoundCell)
'Ajoute la valeur a la variable tableau
Set rng = Union(rng, FoundCell)
'Test pour sortir de la boucle
If FoundCell.Address = FirstFound Then Exit Do
'loop va recommencer la boucle
Loop
'selection du tableau
rng.Columns("A:I").Select
Selection.Copy
' on se place dans la fiche produit
wb.Activate
With ActiveWorkbook
'on colle les données
Selection.Range("A2").PasteSpecial xlPasteFormats
Selection.Range("A2").PasteSpecial xlPasteAll
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Selection.Columns("D").AutoFit
Selection.Columns("B").AutoFit
Selection.Columns("H").AutoFit
Selection.Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Range("A10") = "Nom"
ActiveSheet.Range("A11") = "Date_reception"
ActiveSheet.Columns("A").AutoFit
ActiveSheet.Range("A12") = "N° LOT"
ActiveSheet.Range("D10") = "VALIDATION DU CONTROLE"
ActiveSheet.Range("D10:E10").Merge
ActiveSheet.Range("D11:E12").Merge
ActiveSheet.Range("A10:H12").Select
Selection.Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Range("B10:C10").Merge
ActiveSheet.Range("B11:C11").Merge
ActiveSheet.Range("B12:C12").Merge
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Selection.Borders.LineStyle = 1
Selection.Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Range("A2").EntireRow.Delete
ActiveSheet.Range("A12").EntireRow.Delete
ActiveSheet.Range("F9:H9").Merge
With ActiveSheet.Range("F9").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="N° Bon de retour, N° de dérogation"
End With
ActiveSheet.Range("F9").Interior.ColorIndex = 15
ActiveSheet.Range("F9").VerticalAlignment = xlCenter
ActiveSheet.Range("F9").HorizontalAlignment = xlCenter
ActiveSheet.Range("F11") = "Date :"
ActiveSheet.Range("F11").Interior.ColorIndex = 15
ActiveSheet.Range("F10:H10").Merge
ActiveSheet.Range("F11:H11").Merge
ActiveSheet.Range("F12:H13").Merge
ActiveSheet.Range("F12:H13").Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Rows("11:8").RowHeight = 20
ActiveSheet.Range("D9").HorizontalAlignment = xlCenter
ActiveSheet.Range("D10").HorizontalAlignment = xlCenter
ActiveSheet.Range("B12:C13").Merge
ActiveSheet.Range("A12:A13").Merge
ActiveSheet.Range("A12") = "Visa"
ActiveSheet.Range("A12").VerticalAlignment = xlCenter
ActiveSheet.Range("A12").HorizontalAlignment = xlCenter
ActiveSheet.Range("A12:C13").Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Range("B12").VerticalAlignment = xlCenter
ActiveSheet.Range("B12").HorizontalAlignment = xlCenter
With ActiveSheet.Range("D10").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="Accepté, refusée, Accepté par dérogation"
End With
With ActiveSheet.Range("F12").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Format(Date, "dd/mm/yy")
End With
ActiveSheet.Range("F12").VerticalAlignment = xlCenter
ActiveSheet.Range("F12").HorizontalAlignment = xlCenter
ActiveSheet.Range("A9:A12").Interior.ColorIndex = 15
ActiveSheet.Range("D9").Interior.ColorIndex = 15
ActiveSheet.Columns("B").ColumnWidth = 12
ActiveSheet.Columns("H").ColumnWidth = 8
ActiveSheet.Range("D12:E12").Merge
ActiveSheet.Range("D12") = "Non Conformité"
ActiveSheet.Range("D12").Interior.ColorIndex = 15
ActiveSheet.Range("D12").VerticalAlignment = xlCenter
ActiveSheet.Range("D12").HorizontalAlignment = xlCenter
ActiveSheet.Range("D13:E13").Merge
ActiveSheet.Range("D12:E13").Borders.LineStyle = Excel.XlLineStyle.xlContinuous
ActiveSheet.Name = Format("reference")
' protection des feuilles de calcul
Dim kc As Long
Dim k As Long
kc = ActiveWorkbook.Worksheets.Count
For k = 1 To kc
Sheets(k).Protect DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, Password:="test"
Next k
Sheets("reference").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Unprotect ("test")
ActiveSheet.Name = Format(Date, "dd mmm ")
With ActiveSheet.Range("F12").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Format(Date, "dd/mm/yy")
End With
' Insertion des colonnes "mesure" grâce à une copie du fichier référence
For i = 1 To colonne
ActiveSheet.Range("E1") = ("Mesures " & i)
ActiveSheet.Columns("E").Copy '.Insert Shift:=xlToLeft
ActiveSheet.Columns("E").Insert Shift:=xlToRight
' faire copier coller de la ligne
Next
' Dim y_ As Long, z_ As Long
'For z_ = 5 To colonne
'For y_ = 2 To 7
' If Cells(y_, z_).Value < Cells(y_, colonne + 1).Value And Cells(y_, z_).Value > Cells(y_, colonne + 2).Value Then
'Cells(y_, z_).Interior.ColorIndex = 15
' End If
' Next y_
' Next z_
ActiveSheet.Columns("E:E").Delete
'Fonction anti vide a developper
' Création du bouton sur la feuille contenant les données
ActiveSheet.Range("E2:I9").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=SI(ESTVIDE($A2);FAUX;SI(OU(E2<INDEX($A2:$AA2;;EQUIV(""Valeur minimum"";$A$1:$AA$1;0));E2>INDEX($A2:$AA2;;EQUIV(""Valeur maximum"";$A$1:$AA$1;0)));VRAI;FAUX))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399945066682943
End With
Selection.FormatConditions(1).StopIfTrue = False
ActiveSheet.Buttons.Add(221.5, 492.25, 57.75, 12.75).Select
With Selection
.OnAction = "'Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\fiche_op.xlsm'!Feuil1.Imprimer"
.Characters.Text = "Validé contrôle"
.Font.Bold = True
End With
ActiveSheet.Buttons.Add(221.5, 572.25, 57.75, 12.75).Select
With Selection
.OnAction = "'Z:\Industriel\Projets\Projet contrôle réception\ProjetVBAcode\fiche_op.xlsm'!Feuil1.Imprimer"
.Characters.Text = "Non Conformité"
.Font.Bold = True
End With
Sheets("reference").Visible = 2
ActiveSheet.Columns("D").ColumnWidth = 20
.SaveAs Filename:=chemin & cb1 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Workbooks("tableau_controle.xlsm").Close
End If
Kill (chemin & "temporaire.xlsm")
End If
Exit Sub
'Message d'erreur
NothingFound:
MsgBox ("Aucune valeur " & cb1 & " n'a été trouvé. Veuillez réessayer")
NothingFound_:
MsgBox ("Un problème lors de la saisie du nombre de mesures a été détecté")
End Sub