Import fichier

Le 17/09/2014 à 11:06

Bonjour

Dans un programme effectué par une autre personne, j'obtiens un débogage sur ce code à la ligne 16

Private Sub traiterCSV()
Dim st As String
Dim dernLigne As Long
  st = selectSheet("Quelle période traiter?")
  If st = "" Then Exit Sub
  If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub
  ' - - -
'  ceFichier = ActiveWorkbook.name
  ' - - -
  With Workbooks(ceFichier).Worksheets(st)
    dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("K4").FormulaR1C1 = "=VLOOKUP(RC[-7],DATA_TR!R2C10:R2000C56,20,FALSE)"
    .Range("L4").FormulaR1C1 = "=-VLOOKUP(RC[-8],DATA_TR!R2C10:R2000C56,23,FALSE)"
    .Range("M4").FormulaR1C1 = "=VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,26,FALSE)-VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,29,FALSE)"
    .Range("N4").FormulaR1C1 = "=-VLOOKUP(RC[-10],DATA_TR!R2C10:R2000C56,32,FALSE)"
    .Range("K4:N4").AutoFill Destination:=Range("K4:N" & dernLigne), Type:=xlFillDefault
  End With
End Sub

Qu'est ce que cela signifie ?

Merci beaucoup

Cdt

Le 17/09/2014 à 11:11

Bonjour,

Où se trouve la ligne 16 ?

Le 17/09/2014 à 11:18

La ligne suivante

.Range("K4:N4").AutoFill Destination:=Range("K4:N" & dernLigne), Type:=xlFillDefault

merci

Cdt

Si ca peut aider, voici le code en entier

Option Explicit
Dim tconfig As Variant
Dim tClients As Variant 'La liste des codes clients à traiter
                        'On y rentre :
                        '0 RaisSoc/1 Cle/2 Modele/3 Rep /4 +NomFichier (ex: 13139-2006-01-10.xls)/5 +compteur lignes
Dim tData As Collection 'Ordre formulaire cq : CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
Dim ceFichier As String

' - - - - Le principe
'Un "dictionary" qui contient les codes clients associés avec les infos : raison soc, clé, répertoire, modele, etc
'Une "Collection" qui contient les infos à mettre dans les fichiers demandes avec en premier item le code client.
'On boucle sur le dictionary pour tout ce qui est création fichier, mail , etc.
'On boucle sur la collection pour remplir chaque carnet de cq dejeuner
' - - - - -

Sub nouvellePeriode()
Dim st As String, st2 As String
On Error GoTo Erreur
  st = selectSheet("Choisir la période modèle")
  If st = "" Then Exit Sub
  st2 = InputBox("Entrez le nom de la nouvelle période sous le format suivant : nom complet du mois + année (ex: décembre 2014)")
  If st2 = "" Then Exit Sub
  st2 = Format(CDate(st2), "mmmm yyyy")
  If FeuilleExiste(st2) Then
    MsgBox "Cette feuille existe déjà"
    Exit Sub
  End If
  Worksheets(st).Copy After:=Sheets(ThisWorkbook.Sheets.Count)
  ActiveSheet.name = st2
  ActiveSheet.Cells(2, 5).Value = CDate(st2)
  Exit Sub
Erreur:
  MsgBox "Le format de la période n'est pas valide"
End Sub

Sub genererCommandes()
'Dim sh As Sheets
Dim st As String
  Set tClients = CreateObject("Scripting.dictionary")
  Set tData = New Collection
  ceFichier = ActiveWorkbook.name
  tconfig = Workbooks(ceFichier).Worksheets("CONFIG").Range("tConfig").Value
  st = selectSheet("Quelle période générer?")
  If st = "" Then Exit Sub
  loadData st
  createOrders
  Set tClients = Nothing
  Set tData = Nothing
  Set tconfig = Nothing
End Sub

Sub importDATA()
  ceFichier = ActiveWorkbook.name
  'tConfig = Workbooks(ceFichier).Worksheets("CONFIG").Range("tConfig").Value
  If ouvrirCSV Then traiterCSV
  Workbooks(ceFichier).Worksheets("MENU").Activate
End Sub

' - - - SOUS FONCTIONS genererCOMMANDE- - - - - - - - - -

Private Function selectSheet(ByVal s As String) As String
Dim uf As ufSelectSheet
  Set uf = New ufSelectSheet
  uf.lTitre = s
  uf.Show
  If uf.lbSheets.Value <> "" Then selectSheet = uf.lbSheets.Value Else selectSheet = ""
  Unload uf
End Function

Private Sub loadData(ByVal s As String)
Dim i As Long
Dim dernLigne As Long
With Workbooks(ceFichier).Worksheets(s)
  dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row + 1
  'on tri au cas où
  'r = .Range(.Cells(3, 1), .Cells(.Cells(3, 1).SpecialCells(xlLastCell).Row, 13)).Select
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Sort.SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Sort.SetRange .Range(.Cells(3, 1), .Cells(.Cells(3, 1).SpecialCells(xlLastCell).Row, 14))
  .Sort.Header = xlYes
  .Sort.MatchCase = False
  .Sort.Orientation = xlTopToBottom
  .Sort.SortMethod = xlPinYin
  .Sort.Apply
  'on charge les données dans collection
  i = 4
  'Principe
  ' Récup code client.
  ' Si inconnu, on ajout dans dico avec raison sociale, clé
  ' récup succursale puis ajoute données
  While .Cells(i, 1).Value <> ""
    '.Cells(i, 1)   Ste
    '.Cells(i, 2)   Etab
    '.Cells(i, 3)   succursale
    '.Cells(i, 4)   Matricule
    '.Cells(i, 5)   Nom
    '.Cells(i, 7)   nb cq
    If Not tClients.exists(getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value)) Then
      tClients.Add getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value), _
          Array(getRaisSoc(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getCle(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getModele(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getRep(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value) & "-" & Year(Now()) & "-" & Month(Now()) & "-" & Day(Now()) & ".xls", _
                0)
    End If
    'Ordre formulaire cq : (code client pour ref)+CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
    'On n'ajoute que si nb cq >0
    If .Cells(i, 7).Value > 0 Then _
        tData.Add Array(getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                        .Cells(i, 3).Value, _
                        .Cells(i, 4).Value, _
                        .Cells(i, 5).Value, _
                        .Cells(i, 7).Value, _
                        getValCq(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                        getCqPat(.Cells(i, 1).Value, .Cells(i, 2).Value))
    i = i + 1
  Wend
End With
End Sub

Private Sub createOrders()
Dim i As Long, j As Long
Dim iClients, kClients
Dim nomFichier As String
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
  iClients = tClients.items
  kClients = tClients.keys
  ' - - Creation fichiers
  For i = 0 To tClients.Count - 1
    '0 RaisSoc/1 Cle/2 Modele/3 Rep /4 NomFichier (ex: 13139-2006-01-10.xls)
    nomFichier = iClients(i)(3) & iClients(i)(4)
    Workbooks.Open Filename:=iClients(i)(2) 'on ouvre le modele
    ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlAddIn, CreateBackup:=False
    ActiveWorkbook.Worksheets("Commande").Range("B8").Value = iClients(i)(0)  'Rais soc
    ActiveWorkbook.Worksheets("Commande").Range("B9").Value = Date            'date
    ActiveWorkbook.Worksheets("Commande").Range("E8").Value = kClients(i)     'code client
    ActiveWorkbook.Worksheets("Commande").Range("E9").Value = iClients(i)(1)  'clé
  Next
  ' - -Remplissage commande
  For i = 1 To tData.Count
    'Ordre formulaire cq : (code client pour ref)+CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
    With Workbooks(tClients.Item(tData(i)(0))(4)).Worksheets("Commande")
      j = tClients.Item(tData(i)(0))(5)
      .Cells(j + 15, 1).Value = tData(i)(1)
      .Cells(j + 15, 2).Value = tData(i)(2)
      .Cells(j + 15, 3).Value = tData(i)(3)
      .Cells(j + 15, 4).Value = tData(i)(4)
      .Cells(j + 15, 5).Value = tData(i)(5)
      .Cells(j + 15, 6).Value = tData(i)(6)
    End With
    'On met à jour le compteur de ligne par code client (et donc fichier)
    dictIncLine tData(i)(0)
    iClients = tClients.items
  Next
  ' - - Impression?
  If MsgBox("Imprimer les commandes?", vbYesNo, "Impression") = vbYes Then
    For i = 0 To tClients.Count - 1
      Workbooks(iClients(i)(4)).Worksheets("Commande").PrintOut Copies:=2
    Next
  End If
  ' - - On ferme les commandes
  For i = 0 To tClients.Count - 1
    Workbooks(iClients(i)(4)).Close SaveChanges:=True
  Next
  ' - - EMAILS - - -
  If MsgBox("Préparer les mails?", vbYesNo, "Mails") = vbYes Then
    Set ObjOutlook = New Outlook.Application
    For i = 0 To tClients.Count - 1
      nomFichier = iClients(i)(3) & iClients(i)(4)
      Set oBjMail = ObjOutlook.CreateItem(olMailItem)
      With oBjMail
        .To = "commande@chequedejeuner.fr"
        .Subject = kClients(i) & " - " & Year(Now()) & "-" & Month(Now()) & "-" & Day(Now())
        .htmlBody = "ci joint commande<br><br>cordialement<br><br>" & Application.UserName
        .Attachments.Add nomFichier
        .Display  ' Display plutôt que "send" pour laisser l'utilisateur
                  ' apporter des modifications ou annuler l'envoi
        '.Send
      End With
    Next
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
  End If
End Sub

' - - - SOUS FONCTIONS importDATA - - - - - - - - - - - -
Private Function ouvrirCSV() As Boolean
Dim f As String, s As String
'Dim derLigne As Long
  ouvrirCSV = False
  With Application.FileDialog(msoFileDialogFilePicker)
    '.InitialFileName = tConfig(2, 8)          'On définit le répertoire par défaut
    .Title = "Selectionner l export d ANAEL"  'Définit un titre pour la boîte de dialogue
    .AllowMultiSelect = False                 'Autorise la multi-sélection
    .Filters.Clear                            'Efface les filtres existants.
    .Filters.Add "Classeurs Excel", "*.csv"   'Définit une liste de filtres pour le champ "Type de fichiers".
    '.Filters.Add "Classeurs Excel xls", "*.xls"
    .InitialView = msoFileDialogViewProperties
    .Show                                     'Affiche la boîte de dialogue
    If .SelectedItems.Count = 0 Then Exit Function
    f = .SelectedItems(1)
  End With
  If f <> "" Then
    s = Dir(f)
    'On ouvre le CSV et on copie/colle son contenu
    Workbooks.OpenText Filename:=f, DataType:=1, Semicolon:=True, local:=True
    If Workbooks(s).Worksheets(1).Cells(2, 56).Value <> "TR1" Then
      MsgBox "Il semblerait que l'export d'ANAEL choisi ne soit pas valide, merci de bien vérifier qu'il s'agit de l'état TR1"
      Workbooks(s).Close
      ouvrirCSV = False
      Exit Function
    End If
    'On "nettoie" la feuille DATA (5000 lignes, ça devrait aller)
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2:A5000").EntireRow.Delete
    'On y colle les données du CSV
    Workbooks(s).Worksheets(1).Range(Workbooks(s).Worksheets(1).Cells(2, 1), Workbooks(s).Worksheets(1).Cells(2, 1).SpecialCells(xlLastCell)).Copy
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2").PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Workbooks(s).Close
    'On met en A1 la date du fichier TR1
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A1").FormulaR1C1 = "=DATE(R[1]C[13],R[1]C[12],1)"
    ouvrirCSV = True
  End If
End Function

Private Sub traiterCSV()
Dim st As String
Dim dernLigne As Long
  st = selectSheet("Quelle période traiter?")
  If st = "" Then Exit Sub
  If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub
  ' - - -
'  ceFichier = ActiveWorkbook.name
  ' - - -
  With Workbooks(ceFichier).Worksheets(st)
    dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("K4").FormulaR1C1 = "=VLOOKUP(RC[-7],DATA_TR!R2C10:R2000C56,20,FALSE)"
    .Range("L4").FormulaR1C1 = "=-VLOOKUP(RC[-8],DATA_TR!R2C10:R2000C56,23,FALSE)"
    .Range("M4").FormulaR1C1 = "=VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,26,FALSE)-VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,29,FALSE)"
    .Range("N4").FormulaR1C1 = "=-VLOOKUP(RC[-10],DATA_TR!R2C10:R2000C56,32,FALSE)"
    .Range("K4:N4").AutoFill Destination:=Range("K4:N" & dernLigne), Type:=xlFillDefault
  End With
End Sub

' - - - F O N C T I O N S   U T I L I T A I R E S - - - -
Private Function GetSignature(fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.readall
    TSet.Close
End Function

Private Function FeuilleExiste(stFeuille) As Boolean
  On Error Resume Next
  FeuilleExiste = Not (ActiveWorkbook.Sheets(stFeuille) Is Nothing)
End Function

Private Function getCodeClient(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCodeClient = tconfig(i, 4)
      Exit For
    End If
  Next
End Function

Private Function getValCq(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getValCq = tconfig(i, 7)
      Exit For
    End If
  Next
End Function

Private Function getCqPat(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCqPat = tconfig(i, 8)
      Exit For
    End If
  Next
End Function

Private Function getRaisSoc(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getRaisSoc = tconfig(i, 3)
      Exit For
    End If
  Next
End Function

Private Function getCle(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCle = tconfig(i, 5)
      Exit For
    End If
  Next
End Function

Private Function getModele(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getModele = tconfig(i, 9)
      Exit For
    End If
  Next
End Function

Private Function getRep(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getRep = tconfig(i, 10)
      Exit For
    End If
  Next
End Function

Private Sub dictIncLine(ByVal k As String)
Dim t
  'on extrait l'array
  t = tClients.Item(k)
  'on met à jour
  t(5) = t(5) + 1
  'on remet l'array..
  tClients.Item(k) = t
End Sub

' - - - - TESTS
Private Sub test1()
Dim st2
On Error GoTo Erreur
st2 = InputBox("Entrez le nom de la nouvelle période sous le format suivant : nom complet du mois + année (ex: décembre 2014)")
MsgBox CDate(st2)
Exit Sub
Erreur:
  MsgBox "Le format de la période n'est pas valide"
End Sub

Cdt

Le 17/09/2014 à 11:26

A tester :

Range("K4:N4").AutoFill Destination:=Range("K5:N" & dernLigne), Type:=xlFillDefault
Le 17/09/2014 à 11:29

Merci

Cela ne fonctionne pas

Cdt

Le 17/09/2014 à 11:31

Personnellement, j'opterais pour le code suivant :

Range("K4:N4").Copy Destination:=Range("K5:K" & dernLigne)
Le 17/09/2014 à 11:35

si je fais ca, cela débogue sur cette ligne

If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub

dans ce code

Private Sub traiterCSV()
Dim st As String
Dim dernLigne As Long
  st = selectSheet("Quelle période traiter?")
  If st = "" Then Exit Sub
  If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub
  ' - - -
'  ceFichier = ActiveWorkbook.name
  ' - - -
  With Workbooks(ceFichier).Worksheets(st)
    dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("K4").FormulaR1C1 = "=VLOOKUP(RC[-7],DATA_TR!R2C10:R2000C56,20,FALSE)"
    .Range("L4").FormulaR1C1 = "=-VLOOKUP(RC[-8],DATA_TR!R2C10:R2000C56,23,FALSE)"
    .Range("M4").FormulaR1C1 = "=VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,26,FALSE)-VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,29,FALSE)"
    .Range("N4").FormulaR1C1 = "=-VLOOKUP(RC[-10],DATA_TR!R2C10:R2000C56,32,FALSE)"
    .Range("K4:N4").Copy Destination:=Range("K5:K" & dernLigne)
  End With
End Sub

Cdt

Le 17/09/2014 à 11:40

Pour le coup, si c'est sur la boîte de Message que çà plante, tu peux temporairement l'exclure du code pour voir si le code lui fonctionne comme tu le veux ...

Le 17/09/2014 à 11:44

pourquoi pas

Comment ferais-tu

Merci

Le 17/09/2014 à 11:44

Bonjour,

1 première question : que veux-tu faire avec?

st = selectSheet("Quelle période traiter?")

Cdlt.

Le 17/09/2014 à 11:50

Sélectionner le mois concerné, c'est pourquoi j'ai la msg box

Ensuite il sélectionne l'onglet concerné

C'est pourquoi j'ai envoyé le code complet

Option Explicit
Dim tconfig As Variant
Dim tClients As Variant 'La liste des codes clients à traiter
                        'On y rentre :
                        '0 RaisSoc/1 Cle/2 Modele/3 Rep /4 +NomFichier (ex: 13139-2006-01-10.xls)/5 +compteur lignes
Dim tData As Collection 'Ordre formulaire cq : CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
Dim ceFichier As String

' - - - - Le principe
'Un "dictionary" qui contient les codes clients associés avec les infos : raison soc, clé, répertoire, modele, etc
'Une "Collection" qui contient les infos à mettre dans les fichiers demandes avec en premier item le code client.
'On boucle sur le dictionary pour tout ce qui est création fichier, mail , etc.
'On boucle sur la collection pour remplir chaque carnet de cq dejeuner
' - - - - -

Sub nouvellePeriode()
Dim st As String, st2 As String
On Error GoTo Erreur
  st = selectSheet("Choisir la période modèle")
  If st = "" Then Exit Sub
  st2 = InputBox("Entrez le nom de la nouvelle période sous le format suivant : nom complet du mois + année (ex: décembre 2014)")
  If st2 = "" Then Exit Sub
  st2 = Format(CDate(st2), "mmmm yyyy")
  If FeuilleExiste(st2) Then
    MsgBox "Cette feuille existe déjà"
    Exit Sub
  End If
  Worksheets(st).Copy After:=Sheets(ThisWorkbook.Sheets.Count)
  ActiveSheet.name = st2
  ActiveSheet.Cells(2, 5).Value = CDate(st2)
  Exit Sub
Erreur:
  MsgBox "Le format de la période n'est pas valide"
End Sub

Sub genererCommandes()
'Dim sh As Sheets
Dim st As String
  Set tClients = CreateObject("Scripting.dictionary")
  Set tData = New Collection
  ceFichier = ActiveWorkbook.name
  tconfig = Workbooks(ceFichier).Worksheets("CONFIG").Range("tConfig").Value
  st = selectSheet("Quelle période générer?")
  If st = "" Then Exit Sub
  loadData st
  createOrders
  Set tClients = Nothing
  Set tData = Nothing
  Set tconfig = Nothing
End Sub

Sub importDATA()
  ceFichier = ActiveWorkbook.name
  'tConfig = Workbooks(ceFichier).Worksheets("CONFIG").Range("tConfig").Value
  If ouvrirCSV Then traiterCSV
  Workbooks(ceFichier).Worksheets("MENU").Activate
End Sub

' - - - SOUS FONCTIONS genererCOMMANDE- - - - - - - - - -

Private Function selectSheet(ByVal s As String) As String
Dim uf As ufSelectSheet
  Set uf = New ufSelectSheet
  uf.lTitre = s
  uf.Show
  If uf.lbSheets.Value <> "" Then selectSheet = uf.lbSheets.Value Else selectSheet = ""
  Unload uf
End Function

Private Sub loadData(ByVal s As String)
Dim i As Long
Dim dernLigne As Long
With Workbooks(ceFichier).Worksheets(s)
  dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row + 1
  'on tri au cas où
  'r = .Range(.Cells(3, 1), .Cells(.Cells(3, 1).SpecialCells(xlLastCell).Row, 13)).Select
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Sort.SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Sort.SetRange .Range(.Cells(3, 1), .Cells(.Cells(3, 1).SpecialCells(xlLastCell).Row, 14))
  .Sort.Header = xlYes
  .Sort.MatchCase = False
  .Sort.Orientation = xlTopToBottom
  .Sort.SortMethod = xlPinYin
  .Sort.Apply
  'on charge les données dans collection
  i = 4
  'Principe
  ' Récup code client.
  ' Si inconnu, on ajout dans dico avec raison sociale, clé
  ' récup succursale puis ajoute données
  While .Cells(i, 1).Value <> ""
    '.Cells(i, 1)   Ste
    '.Cells(i, 2)   Etab
    '.Cells(i, 3)   succursale
    '.Cells(i, 4)   Matricule
    '.Cells(i, 5)   Nom
    '.Cells(i, 7)   nb cq
    If Not tClients.exists(getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value)) Then
      tClients.Add getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value), _
          Array(getRaisSoc(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getCle(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getModele(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getRep(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value) & "-" & Year(Now()) & "-" & Month(Now()) & "-" & Day(Now()) & ".xls", _
                0)
    End If
    'Ordre formulaire cq : (code client pour ref)+CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
    'On n'ajoute que si nb cq >0
    If .Cells(i, 7).Value > 0 Then _
        tData.Add Array(getCodeClient(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                        .Cells(i, 3).Value, _
                        .Cells(i, 4).Value, _
                        .Cells(i, 5).Value, _
                        .Cells(i, 7).Value, _
                        getValCq(.Cells(i, 1).Value, .Cells(i, 2).Value), _
                        getCqPat(.Cells(i, 1).Value, .Cells(i, 2).Value))
    i = i + 1
  Wend
End With
End Sub

Private Sub createOrders()
Dim i As Long, j As Long
Dim iClients, kClients
Dim nomFichier As String
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
  iClients = tClients.items
  kClients = tClients.keys
  ' - - Creation fichiers
  For i = 0 To tClients.Count - 1
    '0 RaisSoc/1 Cle/2 Modele/3 Rep /4 NomFichier (ex: 13139-2006-01-10.xls)
    nomFichier = iClients(i)(3) & iClients(i)(4)
    Workbooks.Open Filename:=iClients(i)(2) 'on ouvre le modele
    ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlAddIn, CreateBackup:=False
    ActiveWorkbook.Worksheets("Commande").Range("B8").Value = iClients(i)(0)  'Rais soc
    ActiveWorkbook.Worksheets("Commande").Range("B9").Value = Date            'date
    ActiveWorkbook.Worksheets("Commande").Range("E8").Value = kClients(i)     'code client
    ActiveWorkbook.Worksheets("Commande").Range("E9").Value = iClients(i)(1)  'clé
  Next
  ' - -Remplissage commande
  For i = 1 To tData.Count
    'Ordre formulaire cq : (code client pour ref)+CODE SUCC/MAT/NOM/NB CQ/VAL/P EMPL
    With Workbooks(tClients.Item(tData(i)(0))(4)).Worksheets("Commande")
      j = tClients.Item(tData(i)(0))(5)
      .Cells(j + 15, 1).Value = tData(i)(1)
      .Cells(j + 15, 2).Value = tData(i)(2)
      .Cells(j + 15, 3).Value = tData(i)(3)
      .Cells(j + 15, 4).Value = tData(i)(4)
      .Cells(j + 15, 5).Value = tData(i)(5)
      .Cells(j + 15, 6).Value = tData(i)(6)
    End With
    'On met à jour le compteur de ligne par code client (et donc fichier)
    dictIncLine tData(i)(0)
    iClients = tClients.items
  Next
  ' - - Impression?
  If MsgBox("Imprimer les commandes?", vbYesNo, "Impression") = vbYes Then
    For i = 0 To tClients.Count - 1
      Workbooks(iClients(i)(4)).Worksheets("Commande").PrintOut Copies:=2
    Next
  End If
  ' - - On ferme les commandes
  For i = 0 To tClients.Count - 1
    Workbooks(iClients(i)(4)).Close SaveChanges:=True
  Next
  ' - - EMAILS - - -
  If MsgBox("Préparer les mails?", vbYesNo, "Mails") = vbYes Then
    Set ObjOutlook = New Outlook.Application
    For i = 0 To tClients.Count - 1
      nomFichier = iClients(i)(3) & iClients(i)(4)
      Set oBjMail = ObjOutlook.CreateItem(olMailItem)
      With oBjMail
        .To = "commande@chequedejeuner.fr"
        .Subject = kClients(i) & " - " & Year(Now()) & "-" & Month(Now()) & "-" & Day(Now())
        .htmlBody = "ci joint commande<br><br>cordialement<br><br>" & Application.UserName
        .Attachments.Add nomFichier
        .Display  ' Display plutôt que "send" pour laisser l'utilisateur
                  ' apporter des modifications ou annuler l'envoi
        '.Send
      End With
    Next
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
  End If
End Sub

' - - - SOUS FONCTIONS importDATA - - - - - - - - - - - -
Private Function ouvrirCSV() As Boolean
Dim f As String, s As String
'Dim derLigne As Long
  ouvrirCSV = False
  With Application.FileDialog(msoFileDialogFilePicker)
    '.InitialFileName = tConfig(2, 8)          'On définit le répertoire par défaut
    .Title = "Selectionner l export d ANAEL"  'Définit un titre pour la boîte de dialogue
    .AllowMultiSelect = False                 'Autorise la multi-sélection
    .Filters.Clear                            'Efface les filtres existants.
    .Filters.Add "Classeurs Excel", "*.csv"   'Définit une liste de filtres pour le champ "Type de fichiers".
    '.Filters.Add "Classeurs Excel xls", "*.xls"
    .InitialView = msoFileDialogViewProperties
    .Show                                     'Affiche la boîte de dialogue
    If .SelectedItems.Count = 0 Then Exit Function
    f = .SelectedItems(1)
  End With
  If f <> "" Then
    s = Dir(f)
    'On ouvre le CSV et on copie/colle son contenu
    Workbooks.OpenText Filename:=f, DataType:=1, Semicolon:=True, local:=True
    If Workbooks(s).Worksheets(1).Cells(2, 56).Value <> "TR1" Then
      MsgBox "Il semblerait que l'export d'ANAEL choisi ne soit pas valide, merci de bien vérifier qu'il s'agit de l'état TR1"
      Workbooks(s).Close
      ouvrirCSV = False
      Exit Function
    End If
    'On "nettoie" la feuille DATA (5000 lignes, ça devrait aller)
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2:A5000").EntireRow.Delete
    'On y colle les données du CSV
    Workbooks(s).Worksheets(1).Range(Workbooks(s).Worksheets(1).Cells(2, 1), Workbooks(s).Worksheets(1).Cells(2, 1).SpecialCells(xlLastCell)).Copy
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2").PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Workbooks(s).Close
    'On met en A1 la date du fichier TR1
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A1").FormulaR1C1 = "=DATE(R[1]C[13],R[1]C[12],1)"
    ouvrirCSV = True
  End If
End Function

Private Sub traiterCSV()
Dim st As String
Dim dernLigne As Long
  st = selectSheet("Quelle période traiter?")
  If st = "" Then Exit Sub
  If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub
  ' - - -
'  ceFichier = ActiveWorkbook.name
  ' - - -
  With Workbooks(ceFichier).Worksheets(st)
    dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("K4").FormulaR1C1 = "=VLOOKUP(RC[-7],DATA_TR!R2C10:R2000C56,20,FALSE)"
    .Range("L4").FormulaR1C1 = "=-VLOOKUP(RC[-8],DATA_TR!R2C10:R2000C56,23,FALSE)"
    .Range("M4").FormulaR1C1 = "=VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,26,FALSE)-VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,29,FALSE)"
    .Range("N4").FormulaR1C1 = "=-VLOOKUP(RC[-10],DATA_TR!R2C10:R2000C56,32,FALSE)"
    .Range("K4:N4").AutoFill Destination:=Range("K5:N" & dernLigne), Type:=xlFillDefault
  End With
End Sub

' - - - F O N C T I O N S   U T I L I T A I R E S - - - -
Private Function GetSignature(fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.readall
    TSet.Close
End Function

Private Function FeuilleExiste(stFeuille) As Boolean
  On Error Resume Next
  FeuilleExiste = Not (ActiveWorkbook.Sheets(stFeuille) Is Nothing)
End Function

Private Function getCodeClient(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCodeClient = tconfig(i, 4)
      Exit For
    End If
  Next
End Function

Private Function getValCq(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getValCq = tconfig(i, 7)
      Exit For
    End If
  Next
End Function

Private Function getCqPat(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCqPat = tconfig(i, 8)
      Exit For
    End If
  Next
End Function

Private Function getRaisSoc(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getRaisSoc = tconfig(i, 3)
      Exit For
    End If
  Next
End Function

Private Function getCle(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getCle = tconfig(i, 5)
      Exit For
    End If
  Next
End Function

Private Function getModele(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getModele = tconfig(i, 9)
      Exit For
    End If
  Next
End Function

Private Function getRep(ByVal ste As String, ByVal etab As String) As String
Dim i As Integer
  For i = 1 To UBound(tconfig)
    If tconfig(i, 1) = ste And tconfig(i, 2) = etab Then
      getRep = tconfig(i, 10)
      Exit For
    End If
  Next
End Function

Private Sub dictIncLine(ByVal k As String)
Dim t
  'on extrait l'array
  t = tClients.Item(k)
  'on met à jour
  t(5) = t(5) + 1
  'on remet l'array..
  tClients.Item(k) = t
End Sub

' - - - - TESTS
Private Sub test1()
Dim st2
On Error GoTo Erreur
st2 = InputBox("Entrez le nom de la nouvelle période sous le format suivant : nom complet du mois + année (ex: décembre 2014)")
MsgBox CDate(st2)
Exit Sub
Erreur:
  MsgBox "Le format de la période n'est pas valide"
End Sub

Cdt

Le 17/09/2014 à 12:43

Je pourrais envoyer mon fichier pour comprendre le mécanisme mais j'ai des ifos confidentielles

Cdt

Le 17/09/2014 à 12:56

Pour en revenir aux circonstances initiales, tu as bien dit qu'il s'agit d'un code qui a toujours fonctionné ...???

Si tu veux temporairement exclure une instruction du code, il suffit d'ajouter une apostrophe en début ligne ... ta ligne "verdit" et sera considérée comme un commentaire ...

Le 17/09/2014 à 13:08

Oui cela fonctionnait

J'ai mis l'apostrophe mais cela me renvoie une autre ligne en erreur

With Workbooks(ceFichier).Worksheets(st)

Cdt

Le 17/09/2014 à 13:41

Pour moi c'est dans ce petit pavé là qu'il y a un truc qui ne fonctionne pas bien

Peux-tu regarder stp ?

' - - - SOUS FONCTIONS importDATA - - - - - - - - - - - -
Private Function ouvrirCSV() As Boolean
Dim f As String, s As String
'Dim derLigne As Long
  ouvrirCSV = False
  With Application.FileDialog(msoFileDialogFilePicker)
    '.InitialFileName = tConfig(2, 8)          'On définit le répertoire par défaut
    .Title = "Selectionner l export d ANAEL"  'Définit un titre pour la boîte de dialogue
    .AllowMultiSelect = False                 'Autorise la multi-sélection
    .Filters.Clear                            'Efface les filtres existants.
    .Filters.Add "Classeurs Excel", "*.csv"   'Définit une liste de filtres pour le champ "Type de fichiers".
    '.Filters.Add "Classeurs Excel xls", "*.xls"
    .InitialView = msoFileDialogViewProperties
    .Show                                     'Affiche la boîte de dialogue
    If .SelectedItems.Count = 0 Then Exit Function
    f = .SelectedItems(1)
  End With
  If f <> "" Then
    s = Dir(f)
    'On ouvre le CSV et on copie/colle son contenu
    Workbooks.OpenText Filename:=f, DataType:=1, Semicolon:=True, local:=True
    If Workbooks(s).Worksheets(1).Cells(2, 56).Value <> "TR1" Then
      MsgBox "Il semblerait que l'export d'ANAEL choisi ne soit pas valide, merci de bien vérifier qu'il s'agit de l'état TR1"
      Workbooks(s).Close
      ouvrirCSV = False
      Exit Function
    End If
    'On "nettoie" la feuille DATA (5000 lignes, ça devrait aller)
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2:A5000").EntireRow.Delete
    'On y colle les données du CSV
    Workbooks(s).Worksheets(1).Range(Workbooks(s).Worksheets(1).Cells(2, 1), Workbooks(s).Worksheets(1).Cells(2, 1).SpecialCells(xlLastCell)).Copy
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A2").PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Workbooks(s).Close
    'On met en A1 la date du fichier TR1
    Workbooks(ceFichier).Worksheets("DATA_TR").Range("A1").FormulaR1C1 = "=DATE(R[1]C[13],R[1]C[12],1)"
    ouvrirCSV = True
  End If
End Function

Private Sub traiterCSV()
Dim st As String
Dim dernLigne As Long
  st = selectSheet("Quelle période traiter?")
  If st = "" Then Exit Sub
  If MsgBox("Ajouter les données de " & Format(Workbooks(ceFichier).Worksheets("DATA_TR").Cells(1, 1).Value, "mmmm yyyy") & " sur la feuille """ & st & """?" & vbCrLf & "ATTENTION : Cela remplacera toutes les données présentes dans les colonnes RTT, Maladies, CP et Absences.", vbYesNo) <> vbYes Then Exit Sub
  ' - - -
'  ceFichier = ActiveWorkbook.name
  ' - - -
  With Workbooks(ceFichier).Worksheets(st)
    dernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("K4").FormulaR1C1 = "=VLOOKUP(RC[-7],DATA_TR!R2C10:R2000C56,20,FALSE)"
    .Range("L4").FormulaR1C1 = "=-VLOOKUP(RC[-8],DATA_TR!R2C10:R2000C56,23,FALSE)"
    .Range("M4").FormulaR1C1 = "=VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,26,FALSE)-VLOOKUP(RC[-9],DATA_TR!R2C10:R2000C56,29,FALSE)"
    .Range("N4").FormulaR1C1 = "=-VLOOKUP(RC[-10],DATA_TR!R2C10:R2000C56,32,FALSE)"
    .Range("K4:N4").AutoFill Destination:=Range("K5:N" & dernLigne), Type:=xlFillDefault
  End With
End Sub

Merci

Cdt

Le 17/09/2014 à 14:58

Re,

Je suppose que la première ligne de ton module dit : Option Explicit ...

Est-ce-que tu sais comment tu as défini les variables cefichier et st ...? Dim cefichier As xxx et Dim st As xxx

Le 17/09/2014 à 15:06

Non c'est une personne qui est parti qui a fait ce fichier

Cdt

Le 17/09/2014 à 15:17

OK ...

Ce qui parait bizarre, c'est que tu dis que le code a toujours marché auparavant ...

Quelle est donc la modification qui est intervenue pour qu'il ne fonctionne plus ...

Je viens de voir que tu as :

  • Dim cefichier As String , ce qui ne pose pas de problème ...
  • Mais tu as aussi Dim st As String , puisqu'il s'agit du mois ... comment est saisi le mois : en nombre ou en lettres ?
Le 17/09/2014 à 15:30

Voici pour t'aider à comprendre le truc le fichier CD qui est le fichier automatisé et le csv à intégrer

J'ai enlevé tous les noms

Cdt

Le mois est saisi sous le format septembre 2014

Cdt

Le 17/09/2014 à 20:32

Bonsoir

Le code va chercher un fichier qu'il colle dans l'onglet data et rapatrié les absences sur la feuilleton mois demandé

Cddt

Rechercher des sujets similaires à "import fichier"