Concaténation de feuille excel

Version imprimable

Bonjour,
J'essaye de concaténer des feuilles excel dans un répertoire donné en une seul, les feuilles contiennent les même colonnes, j'ai fait une macro pour cela dont le code est le suivant

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Sub RegrouperFeuille()
 
Dim rep As String
    Dim wk As Workbook
    Dim XlApp As New Excel.Application
    Dim XlBook As Workbook
    Dim XlSheet As Worksheet
    Dim ExisteFichier As Boolean
    Dim nomFic As String
    'Variable pour permettre de gerer les entetes
    Dim i As Integer
    i = 1
 
    'On Error GoTo Erreur_Fichier:
    Set XlBook = XlApp.Workbooks.Add
    Set XlSheet = XlBook.Worksheets(1)
 
 
 
    ' test de l'existence du fichier prestataire
     nomFic = ThisWorkbook.path & "\FichierPrestataire.xls"
     ExisteFichier = (Dir(nomFic) <> "")
     If ExisteFichier = True Then
        Kill nomFic
     End If
 
     XlBook.SaveAs ThisWorkbook.path & "\FichierPrestataire"
 
 
    Dim l As Long
    'Initialisations
    l = 5
    rep = ThisWorkbook.path & "\Prestataires\"
    s = Dir(rep)
 
 
    Do
        Set wk = CreateObject(rep & s)
    wk.Activate
    If i = 1 Then
    Range("A3").Select
    Else
    Range("A7").Select
    End If
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    XlBook.Activate
    If i = 1 Then
    l = XlSheet.Range("A65356").End(xlUp).Row
    Else
    l = XlSheet.Range("A65356").End(xlUp).Row + 1
    End If
    XlSheet.Range("A" & l).Select
    XlSheet.Paste
    wk.Activate
    Application.CutCopyMode = False
        wk.Close savechanges:=False
 
        s = Dir
        i = i + 1
    Loop While s <> ""
      XlBook.Save
    XlApp.Quit
'Erreur_Fichier:
    'MsgBox "Le Dossier Prestataire ne contient aucun fichier"
 
 
End Sub

1 ) J'ai le bon résultat dans le fichier cible, le problème est que j'ai des cellules en couleurs qui apparaissent en fin du fichier créé et je ne vois pas trop d'ou sa viens si quelqu'un à une idée.

2) Que dois-je faire pour que la largeur des cellules soit modifié automatiquement selon la taille du plus grand chiffre de la colonne dans le nouveau fichier créé?

09/06/2011, 11h50
amnorian

visiblement tu fais du copier coller, tes feuilles d'origines ne sont elles pas déja colorées ?

pour ta deuxieme question juste en utilisant l'enregistreur de macro

Code:

Columns("C:C").EntireColumn.AutoFit

il y a, peu être, une meilleure méthode
09/06/2011, 12h13
Psycho185

Pour Columns("C:C").EntireColumn.AutoFit si je l'intègre après de la ligne 52 dans le code fournis sa marche pas.
Je ne vois pas ou la mettre autre part car quand je règle la taille des cellules manuellement c'est ici que je le fait.
Pour mes feuilles d'origines l'entête est colorié (le nom des colonnes) mais pas de couleur autre part.
09/06/2011, 13h00
kiki29

Salut; XlSheet...... et à priori après la ligne 61

Sinon la question de concaténation est récurrente voir http://www.google.fr/#sclient=psy&hl...w=1007&bih=725
09/06/2011, 13h39
Psycho185

Pour la mise en forme des cellules sa marche effectivement, merci kiki et amnorian,
Par contre kiki29 ma question n'est pas sur comment concaténer des feuilles xls vu que le code que j'ai fournit le fait bien mais plutôt sur les apparitions étrange de cellules en couleur à la fin du fichier créé.
Désolé si je ne suis pas assez explicite.

J'ai modifier un peu ma précédente macro pour gérer les apparition bizarre de cellule en couleur et la disparition de bordure de cellule et faire la mise en forme automatique des cellules dans le fichier résultat.

Vu que je n'ai pas d'idée à l'avance d'ou vont apparaître ces fameuses cellules j'ai fait un traitement sur "A3:K1000" donc sa me prend pas mal de temps pour copier que quelque ligne au final ( environ 3 minutes).

Donc si quelqu'un à une idée de comment accélérer les choses ou gérer le problème initial je suis preneur :)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
' Consolider des données à partir de plusieurs feuilles
    Dim rep As String
    Dim wk As Workbook
    Dim ExisteFichier As Boolean
    Dim nomFic As String
    'Variable pour permettre de gerer les entetes
    Dim i As Integer
    i = 1
 
    'On Error GoTo Erreur_Fichier:
    Set XlBook = XlApp.Workbooks.Add
    Set XlSheet = XlBook.Worksheets(1)
 
 
 
    ' test de l'existence du fichier prestataire
     nomFic = ThisWorkbook.path & "\FichierPrestataireRes.xls"
     ExisteFichier = (Dir(nomFic) <> "")
     If ExisteFichier = True Then
        Kill nomFic
     End If
 
     XlBook.SaveAs ThisWorkbook.path & "\FichierPrestataireRes"
 
 
    Dim l As Long
    'Initialisations
    l = 3
    rep = ThisWorkbook.path & "\Prestataires\"
    s = Dir(rep)
 
 
    Do
        Set wk = CreateObject(rep & s)
    wk.Activate
 
    If i = 1 Then
    'recopier le masque du fichier
 
    Range("A5").Select
    Else
 
    'recopier les données à partir de la ligne 7 (modifier A7 par Ai si les données commencent à la ligne i)
    Range("A7").Select
    End If
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    XlBook.Activate
 
    If i = 1 Then
    l = XlSheet.Range("A65356").End(xlUp).Row
    Else
    l = XlSheet.Range("A65356").End(xlUp).Row + 1
    End If
 
    'MsgBox " feuille active avant loop " & ActiveSheet.Name
    XlSheet.Range("A" & l).Select
 
    XlSheet.Paste
    wk.Activate
    Application.CutCopyMode = False
        wk.Close savechanges:=False
 
        s = Dir
        i = i + 1
    Loop While s <> ""
 
 
    'formatage de largeur de cellule pour affichage optimal
    XlSheet.Columns("A:K").EntireColumn.AutoFit
 
 
    ' gestion de l'apparition de couleur et de disparition de bordure de cellule
 
    Dim Cell As Range
    For Each Cell In XlSheet.Range("A3:K1000")
       Cell.Interior.Color = vbWhite
       Cell.Borders.Weight = 1
    Next Cell
 
    XlBook.Save
    XlApp.Quit
 
    Range("A1").Select
    Selection.Copy
    Range("A2").Select
    ActiveSheet.Paste