Manipulation de classeur fermé

Option Explicit

Dim Donnees(), valeurs()

Sub Import()
Dim FeuilleAimporter As String, Classeur As String, Chemin As String, numChamp As Integer

Classeur = "Préventif_CFE_Planning 2014.xlsm"
FeuilleAimporter = "Suivi"
Chemin = "\\frsf-sanview\profiles$\trichoux\Bureau\Dossier théo\Dossier graissage\" & Classeur
Erase Donnees
Erase valeurs
ImporterLaTable FeuilleAimporter, Chemin, numChamp
End Sub

Sub ImporterLaTable(NomFeuilSource As String, strChemin As String, Colonne As Integer)
Dim Cn As Object
Dim rst As Object

Set Cn = CreateObject("ADODB.connection")
Set rst = CreateObject("ADODB;Recordset")
With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
 End With

pour joindre une pièce
mettre le classeur sans données confidentielles en pièce jointe sur
http://cjoint.com/ 
puis copier l'adresse du lien et la coller dans le message de réponse 

 

Function ExisteFichier(fcher As String) As Boolean
ExisteFichier = (Dir(fcher & ".xlsm") <> "")
End Function


Sub Générale()

'Macro qui lance l'userform pour le choix du mois

Demandemois.Show
Dim fichiersource As String
retard = Demandemois.choix 'on enregistre le choix de la prise en compte des retards
moisdemandé = Demandemois.verif 'on enregistre le mois de plannif choisi
fichiersource = Demandemois.dossier 'On enregistre le planning choisi
Unload Demandemois

'Macro qui extrait le planning

    Dim i As Integer
    Dim derlig As Long
    Dim Fichier As String
    Dim fichier1 As String
    Dim a As Integer
    Dim base As String
    Dim nom As String
    Dim ligne As Integer
    Dim colonne As Integer
    nom = ActiveWorkbook.Name
    

 
   
   
    fichier1 = StrReverse(fichiersource)
    a = InStr(fichier1, "\")
    Fichier = Right(fichiersource, a - 1) & ".xlsm"
    
     'Vérification existance fichier
     
   While ExisteFichier(fichiersource) = False And i < 5
        i = i + 1
        fichiersource = InputBox("Veuillez renseigner un nom de fichier valide, essai " & i & "/5", "Fichier introuvable", fichiersource)
   Wend
   
   'Ouverture du planning
    Workbooks.Open(fichiersource & ".xlsm").Activate
    Sheets("Suivi").Activate
    
    'Génération d'une variable tableau pour entrer le planning
    Dim tabplan()
    derlig = Range("B9").End(xlDown).Row 'on cherche la taille du tableau
    ReDim tablodate(derlig - 2, 14)

'On entre le planning dans la variable tableau
  
  
 For ligne = 9 To derlig
       For colonne = 26 To 40
            tablodate(ligne - 8, colonne - 26) = Workbooks(Fichier).Sheets("Suivi").Cells(ligne, colonne).Value
       Next
 Next

'On génère la variable tableau qui va chercher les postes plannifiés pour le mois demandé.

Dim tablopostes()

'On cherche maintenant la dimension du tableau
Dim nPlanifié As Integer
nPlanifié = 0
For ligne = 9 To derlig
    If Cells(ligne, 2) Like "GRA*" Then 'Si l'opération plannifié concerne le graissage
        If Cells(ligne, moisdemandé + 25) Like "*P" Then
            nPlanifié = nPlanifié + 1
        End If
    End If
Next

Dim nRetard As Integer
nRetard = 0

If retard = True Then 'prise en compte des retards
    For ligne = 9 To derlig
        If Cells(ligne, 2) Like "GRA*" Then 'Si l'opération plannifié concerne le graissage
            If Cells(ligne, 26) Like "*R*" Then
                nRetard = nRetard + 1
            End If
        End If
    Next
End If

Dim Nbligne As Integer
Nbligne = nPlanifié + nRetard 'On a trouvé notre nombre de ligne
ReDim tablopostes(Nbligne, 2) 'On redimentionne donc le tableau

'On rempli maintenant le tableau avec les numéros de poste à prendre en compte
Dim position_ As Long
Dim j As Integer
Dim Tableau() As String
j = 0

For ligne = 9 To derlig
    If Cells(ligne, 2) Like "GRA*" Then 'Si l'opération plannifié concerne le graissage
        If Cells(ligne, moisdemandé + 25) Like "*P" Then
            j = j + 1
            position_ = InStr(Cells(ligne, 4), "_") 'On cherche la position du caractere "_" dans la désignation du poste
    
                If position_ = 0 Then
                    MsgBox ("Numéro de poste invalide à la ligne " & ligne & " merci de corriger") 'S'il n'y a pas de "_" dans la cellule alors on affiche un message d'avertissement
                    tablopostes(j, 1) = Cells(ligne, 4).Value 'On rentre quand même la valeur brute dans le tableau, sachant qu'elle risque de ne pas être prise en compte lors de la rcherche des specs
                Else
                    tablopostes(j, 1) = Mid(Cells(ligne, 4), position_ + 1, 10) 'On rentre le numéro de poste dans le tableau
                End If
    
             'on va maintenant rentrer dans la deuxième colonne de tablopostes l'action à effectuer
            'découpe la chaine en fonction des espaces " "
            'le résultat de la fonction Split est stocké dans un tableau
            Tableau = Split(Cells(ligne, 2), "-")
            tablopostes(j, 2) = Tableau(1)
    
        End If
    End If
Next
  

If retard = True Then 'prise en compte des retards
    For ligne = 9 To derlig
        If Cells(ligne, 2) Like "GRA*" Then 'Si l'opération plannifié concerne le graissage
            If Cells(ligne, 26) Like "*R*" Then
                j = j + 1
                position_ = InStr(Cells(ligne, 4), "_") 'On cherche la position du caractere "_" dans la désignation du poste
    
                If position_ = 0 Then
                    MsgBox ("Numéro de poste invalide à la ligne " & ligne & " merci de corriger") 'S'il n'y a pas de "_" dans la cellule alors on affiche un message d'avertissement
                    tablopostes(j, 1) = Cells(ligne, 4).Value 'On rentre quand même la valeur brute dans le tableau, sachant qu'elle risque de ne pas être prise en compte lors de la rcherche des specs
                Else
                    tablopostes(j, 1) = Mid(Cells(ligne, 4), position_ + 1, 10) 'On rentre le numéro de poste dans le tableau
                End If
    
            Tableau = Split(Cells(ligne, 2), "-")
            tablopostes(j, 2) = Tableau(1)
            End If
        End If
    Next
End If

'on va maintenant demander à l'utilisateur quel est le dossier ou se trouve les fichiers spec
 Dim objShell As Object, objFolder As Object
     Dim Chemin As String, Msg As String
     Dim FlagChoix As Long, NbPoint As Integer

     If SelType = 0 Then
          FlagChoix = &H1
          Msg = "Sélectionner un dossier :"
     Else
          FlagChoix = &H4000
          Msg = "Sélectionner un fichier :"
     End If

     Set objShell = CreateObject("Shell.Application")
     Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix)
    
'Si l 'objet retourné est valide, on teste son contenu (item.title)
     'Si on a sélectionné la racine d'une partition, il se compose du nom de la partition,
     ' suivi de sa lettre et ":" entre parenthèses
     NbPoint = InStr(objFolder.Title, ":")
     If NbPoint = 0 Then
          
'Sinon, il se compose du nom du dossier uniquement, sans le chemin précédent
          'On récupère ce chemin à l'aide des propriété et méthode ParentFolder.ParseName
          Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
     Else
          

Chemin = Mid(objFolder.Title, NbPoint - 1, 2) ' si racine on récupère la lettre du lecteur et les 2 points

     End If
     choixdossierfichier = Chemin
     MsgBox choixdossierfichier
    
    'On va maintenant chercher les specs en fonction des postes plannifiés
    Dim FSO As Scripting.FilesystemObject
    Dim DossierSource As Scripting.Folder
    Dim spec As Scripting.file
    Dim r As Long
    Dim derlign As Long
    Set FSO = New Scripting.FilesystemObject
    Set DossierSource = FSO.GetFolder(Chemin)
    
    r = 0
    
    For i = 1 To UBound(tablopostes, 1)
        For Each spec In DossierSource.Files
            If spec.Name Like tablopostes(i, 1) & ".xlsx" Then
                Dim Source As ADODB.Connection
                Dim Rst As ADODB.Recordset
                Dim ADOCommand As ADODB.Command
                Dim nFichier As String, Cellule As String, Feuille As String
                Dim nLigne As Integer
                
                'plage de cellules à importer
                Cellule = "A12:G30"
                
      
                Feuille = "Plan de maintenance$" 'n'oubliez pas d'ajouter $ au nom de la feuille.
                
                nFichier = choixdossierfichier & "\" & spec.Name 'Chemin complet du classeur fermé
                
                Set Source = New ADODB.Connection
                With Source
                    .Provider = "Microsoft.Jet.OLEDB.4.0"
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                     & nFichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
                    .Open
                End With


                Set ADOCommand = New ADODB.Command
                With ADOCommand
                    .ActiveConnection = Source
                    .CommandText = "SELECT * FROM [" & Feuille & Cellule & "]"
                End With
                  
                Set Rst = New ADODB.Recordset
                Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
                  
                Set Rst = Source.Execute("[" & Feuille & Cellule & "]")
                Workbooks("test.xlsm").Activate
                derlign = Range("B1").End(xlDown).Row
                
                If derlign > 10000 Then
                    Range("B1").CopyFromRecordset Rst
                   
                    For nLigne = 10 To 1 Step -1
                        If Cells(nLigne, 5).Value <> tablopostes(i, 2) Then
                            Range("A" & nLigne & ":" & "H" & nLigne).Delete
                        End If
                    Next
                     Range("A1") = tablopostes(i, 1)
                Else
                
                    Range("B" & derlign + 1).CopyFromRecordset Rst
                    
                    
                    For nLigne = derlign + 10 To derlign + 1 Step -1
                        If Cells(nLigne, 5).Value <> tablopostes(i, 2) Then
                            Range("A" & nLigne & ":" & "H" & nLigne).Delete
                        End If
                    Next
                    Range("A" & derlign + 1) = tablopostes(i, 1)
                End If
            
                Rst.Close
                Source.Close
                Set Source = Nothing
                Set Rst = Nothing
                Set ADOCommand = Nothing

                
            End If
        Next spec
    Next
    
    Set spec = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
    
End Sub