XL 2019 Extraire les données d'un fichier fermer pour les coller dans un fichier que l'on doit créer

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
J

jui42

XLDnaute Junior
Bonjour,
Je suis novice en VBA et j'aimerais automatisé certaines choses au boulot,
Mon problème est le suivant : J'ai un fichier avec toutes les références de produits que l'on réceptionne.
L'idée est donc, que l'opérateur à un premier fichier ( on l'appellera fichier A) avec uniquement des référence de produit, lorsque l'opérateur clique sur une référence, un fichier de suivis de cette référence se crée (On l'appellera fichier i) propre au suivis de cette référence avec des données qui sont importé depuis une base de donnée et que le fichier i s'incrémente d'une nouvelle date si l'on clique deux fois dessus.

J'arrive à faire cela mais pour un seul fichier, je n'arrive pas à généraliser pour toutes les références.
Pourriez vous me venir en aide ?
 
Trier par date Trier par votes
Bonjour, au cas où quelqu'un se baladerais sur ce fil, voici le programme nécéssaire.
VB: 
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
            
        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
                    ' 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.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
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Question Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
K
  • Résolu(e)
Microsoft 365 Ouvrir un autre classeur excel (VBA) pour utiliser les données de celui dans le classeur actif
Réponses
5
Affichages
1 K
Dranreb
Dranreb
XLSM75
  • Question Question
XL 2019 Extraire données d'un classeur vers un autre en réorganisant et renommant les colonnes
Réponses
10
Affichages
2 K
XLSM75
XLSM75
O
  • Question Question
XL 2013 Macro qui copie des données d'un fichier pour les coller dans un autre fichier selon des règles particulières
Réponses
7
Affichages
1 K
onyirimba
O
M
  • Question Question
XL 2016 Extraire des données d'un fichier CSV vers un fichier Excel avec critères
Réponses
1
Affichages
2 K
Hasco
Hasco
!xmusaton
  • Question Question
XL 2016 Copier les données d'un classeur dans un deuxième classeur fermé
Réponses
3
Affichages
2 K
!xmusaton
!xmusaton
S
  • Question Question
Microsoft 365 Extraire les champs d'un fichier PDF dans un Excel
Réponses
4
Affichages
3 K
sj4555
S
S
  • Question Question
XL 2016 vba : Faire une recherche de données dans fichier externe fermé
Réponses
12
Affichages
3 K
James007
James007
C
  • Question Question
XL 2019 Macro : Ouvrir un fichier, exécuter une macro dans ce fichier puis exporter les données vers un autre classeur
Réponses
1
Affichages
1 K
CiolBel
C
J
  • Question Question
XL 2016 Exporter les données d'une feuille excel (fichier utilisateurs) vers un autre classeurs excel (base de données)
Réponses
3
Affichages
1 K
Yaloo
Y
Z
  • Question Question
copier une feuille d'un classeur fermé dans un classeur ouvert
Réponses
1
Affichages
3 K
herve62
herve62
N
  • Question Question
Enregistrer plusieurs lignes dans un fichier fermé
Réponses
4
Affichages
2 K
nak
N
M
  • Question Question
Saisi d'un chemin d'un fichier via un userform pour traitement par un script
Réponses
5
Affichages
2 K
Miguel973
M
P
  • Question Question
bout de code pour fermer un classeur après importation d'un onglet
Réponses
10
Affichages
2 K
YANN-56
YANN-56
S
  • Question Question
VBA : coller données d'un tableau dans autres les autres feuilles du classeur
Réponses
4
Affichages
3 K
superbya
S
A
  • Question Question
extraire les données d'un USF pour les coller dans un tableau
Réponses
4
Affichages
1 K
G.David
G.David
M
  • Question Question
Ajouter une feuille dans un classeur fermé
Réponses
2
Affichages
9 K
MichelXld
M
Retour