Créer des classeurs excel en fonction des données d'une feuille. [Résolu]

Messages postés
7
Date d'inscription
mercredi 16 mai 2007
Statut
Membre
Dernière intervention
29 octobre 2008
- - Dernière réponse : sinxay
Messages postés
7
Date d'inscription
mercredi 16 mai 2007
Statut
Membre
Dernière intervention
29 octobre 2008
- 27 oct. 2008 à 15:02
Bonjour,

J'arrive a obtenir mes nouveaux classeurs avec les bons données dedans.

Mais je n'arrive pas à faire l'enregistrement et la fermeture en me servant de la valeur de la cellule servant de condition.

      Voici mon code:
=======================
Sub Creationdefichiers()


Dim WkClient As Workbook
Dim ligmax As Long
Dim numlig As Long
Dim ligcop As Long
Dim col As String


'depart de lecture ligne 1
ligmax = 1
'resitriction des verification sur la colonne D
col = "D"
 
'clause de sortie de la macro
While Cells(ligmax, col).Value <> ""


    'initialisation du nouveau cycle
    numlig = ligmax
    'réinitialisation du compteur
    ligcop = 1
   
    'ouverture d'un nouveau classeur
    Set WkClient = Workbooks.Add
    '--Suppression des messages d'alerte
     Application.DisplayAlerts = False
    '--Suppression des feuilles inutiles suite à l'importation
    'Sheets("Feuil2").Delete
    'Sheets("Feuil3").Delete


        While Cells(numlig, col) = Cells(numlig + 1, col)
       
        Cells(numlig, col).EntireRow.Copy
        Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
   
        numlig = numlig + 1
        ligcop = ligcop + 1


        Wend
       
    Cells(numlig, col).EntireRow.Copy
    Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
    MsgBox (Cells(numlig, col))
    'Workbooks(WkClient).SaveAs Filename:="Cells(numlig, col)"
    'Workbooks(Cells(numlig, col)).Close savechanges:=True
    WkClient.Close savechanges:=False
   
ligmax = ligmax + ligcop


Wend


End Sub
====================

Soit je n'ai pas compris la syntaxe soit il faut faire autrement.

Si quelqu'un peut me filer un coup de main, merci d'avance.
Afficher la suite 

3 réponses

Meilleure réponse
Messages postés
7401
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
42
3
Merci
Salut,
Essaies peu être

Call Workbooks(WkClient).SaveAs(Cells(numlig, col).Value)
Call Workbooks(WkClient).Close
, ----
[../code.aspx?ID=41455 By Renfield]
en partant du principe que ce sont les ligne  en rouge qui posent problème.

@+: Ju£i€n
Pensez: Réponse acceptée

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 134 internautes nous ont dit merci ce mois-ci

Commenter la réponse de jrivet
Messages postés
7
Date d'inscription
mercredi 16 mai 2007
Statut
Membre
Dernière intervention
29 octobre 2008
3
Merci
Merci Julien,


En fait j'ai un peu modifier mon code et trouvé quelque chose qui fonctionne.


Il me reste à percer le mistère de l'acriture unique.


En fait la colonne E du fichier ne doit en aucun cas avoir 2 fois la même valeur. Donc avant de copier chaque ligne je doit vérifier la condition.

==============

Sub Creationdefichiers()


Dim WkClient As Workbook
Dim ligmax As Long
Dim numlig As Long
Dim ligcop As Long
Dim col As String
Dim col2 As String
Dim nom As String
Dim chemin As String


chemin = "f:\test\reverse"


'depart de lecture ligne 1
ligmax = 1
'resitriction des verification sur la colonne D
col = "D"
col2 = "E"
 
'clause de sortie de la macro
While Cells(ligmax, col).Value <> ""


    'initialisation du nouveau cycle
    numlig = ligmax
    'réinitialisation du compteur
    ligcop = 1
   
    'initialisation du nom et repertoire client
    nom = Cells(numlig, col).Value
    MsgBox (nom)
    cheminclient = chemin & nom
       
    'verification de l'existance du classeur
    If Dir(chemin & nom, 16) = "" Then
        'création du répertoire
        MkDir chemin & nom
        cheminclient = chemin & nom
        'ouverture d'un nouveau classeur
        Set WkClient = Workbooks.Add
        '--Suppression des messages d'alerte
         Application.DisplayAlerts = False
        '--Suppression des feuilles inutiles suite à l'importation
        Sheets("Feuil2").Delete
        Sheets("Feuil3").Delete
        ActiveWorkbook.SaveAs Filename:=cheminclient & "" & nom & " rac-cnx" & ".xls"
   
        Else: Workbooks.Open Filename:=cheminclient & "" & nom & " rac-cnx" & ".xls"
   
    End If
    
        'boucle de copie des lignes client
        While Cells(numlig, col) = Cells(numlig + 1, col)
        
        condition si la valeur de la cellule (numlig,col2) existe dans la colonne alors copie
        Cells(numlig, col).EntireRow.Copy
        Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
        'maj des compteurs
        numlig = numlig + 1
        ligcop = ligcop + 1


        Wend
condition si la valeur de la cellule (numlig,col2) existe dans la colonne alors copie
    'copie de la dernière ligne client
    Cells(numlig, col).EntireRow.Copy
    Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
           
    'fermeture du fichier
    ActiveWorkbook.Close savechanges:=True
ligmax = ligmax + ligcop


Wend


End Sub


========

Je commence ma recherche mais je ne sais pas trop par ou aller.

Merci de votre aide.

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 134 internautes nous ont dit merci ce mois-ci

Commenter la réponse de sinxay
Messages postés
7
Date d'inscription
mercredi 16 mai 2007
Statut
Membre
Dernière intervention
29 octobre 2008
3
Merci
Héhé ça mache au cas ou ça serve à quelqu'un d'autre.

Si il est possible de rendre le tout plus lisible ou plus court je suis preneur


===============


Sub Creationdefichiers()


Dim WkClient As Workbook
Dim ligmax As Long
Dim numlig As Long
Dim ligcop As Long
Dim col As String
Dim col2 As String
Dim nom As String
Dim chemin As String
Dim Existe As Boolean
Dim Produit As String



'rep de travail
chemin = "f:\test\reverse"



'depart de lecture ligne 1
ligmax = 1
'resitriction des verification sur la colonne D
col = "D"
col2 = "E"
'init vérif
Existe = False
 
'clause de sortie de la macro
While Cells(ligmax, col).Value <> ""




    'initialisation du nouveau cycle
    numlig = ligmax
    'réinitialisation du compteur
    ligcop = 1
   
    'initialisation du nom et repertoire client
    nom = Cells(numlig, col).Value
    MsgBox (nom)
    cheminclient = chemin & nom
       
    'verification de l'existance du classeur
    If Dir(chemin & nom, 16) = "" Then
        'création du répertoire
        MkDir chemin & nom
        cheminclient = chemin & nom
        'ouverture d'un nouveau classeur
        Set WkClient = Workbooks.Add
        '--Suppression des messages d'alerte
         Application.DisplayAlerts = False
        '--Suppression des feuilles inutiles suite à l'importation
        Sheets("Feuil2").Delete
        Sheets("Feuil3").Delete
        ActiveWorkbook.SaveAs Filename:=cheminclient & "" & nom & " rac-cnx" & ".xls"
   
        Else: Workbooks.Open Filename:=cheminclient & "" & nom & " rac-cnx" & ".xls"
        '--Suppression des messages d'alerte
        Application.DisplayAlerts = False
        
    End If
 
    'Condition boucle de copie des lignes client
    While Cells(numlig, col) = Cells(numlig + 1, col)
        Produit = Cells(numlig, col2).Value
        'vérification de la non présernce de la ligne à copier
        i = 1
        While (Sheets("feuil1").Cells(i, col2)) <> ""            If Produit Sheets("feuil1").Cells(i, col2) Then Existe True
            i = i + 1
        Wend
        'validation de la ligne à copier
        If Existe = False Then
            Cells(numlig, col).EntireRow.Copy
            Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
        End If
       
        'maj des compteurs
        Existe = False
        numlig = numlig + 1
        ligcop = ligcop + 1


    Wend
       
    'copie de la dernière ligne client
    Produit = Cells(numlig, col2).Value
    'vérification de la non présernce de la ligne à copier
    i = 1
    While (Sheets("feuil1").Cells(i, col2)) <> ""        If Produit Sheets("feuil1").Cells(i, col2) Then Existe True
        i = i + 1
    Wend
    'validation de la ligne à copier
    If Existe = False Then
        Cells(numlig, col).EntireRow.Copy
        Sheets("feuil1").Cells(ligcop, 1).Insert Shift:=xlDown
    End If
    Existe = False
      
    'fermeture du fichier
    ActiveWorkbook.Close savechanges:=True
       
    ligmax = ligmax + ligcop


Wend


End Sub




==================

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 134 internautes nous ont dit merci ce mois-ci

Commenter la réponse de sinxay