Discussion :

[Psycho185]

Bonjour,

j'ai fait un petit bout de code en vba qui concatène les feuille Excel d'un répertoire en une seul, la copie se passe bien, et j'ai le bon résultat en ce qui concerne les données, par contre j'ai des apparitions bizarre du genre cellule en couleur (j'arrive pas à vous mettre de photo pour mieux expliciter le problème) sachant que je ne modifie la couleur des cellules nul part ailleurs dans mon programme.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
88
89
90
91
92
93
94
95
96
97
98
 
' 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 = 5
    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("A3").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
 
    'formatage de largeur de cellule pour affichage optimal
 
    XlSheet.Range(XlSheet.Cells(1, 1), XlSheet.Cells(1, 2)).ColumnWidth = 20
 
    XlSheet.Range(XlSheet.Cells(1, 4), XlSheet.Cells(1, 5)).ColumnWidth = 36
 
    XlSheet.Range(XlSheet.Cells(1, 6), XlSheet.Cells(1, 7)).ColumnWidth = 22
 
    XlSheet.Range(XlSheet.Cells(1, 8), XlSheet.Cells(1, 9)).ColumnWidth = 15
 
    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
 
    Range("A1").Select
    Selection.Copy
    Range("A2").Select
    ActiveSheet.Paste
 
 
 
'Erreur_Fichier:
    'MsgBox "Le Dossier Prestataire ne contient aucun fichier"
 
 
 
'Fermeture des classeurs sauf le classeur actif
'En enregistrant les modifications
 
For Each XlBook In Workbooks
    If XlBook.Name <> ThisWorkbook.Name Then
        XlBook.Close True
    End If
Next XlBook

Si quelqu'un a une idée d'ou sa viens!?
[IMG]D:\temp\res.jpeg[/IMG]