Petite modification d'un code VBA

Version imprimable

Bonjour,
J'ai adapté la macro ci-dessous mais mon niveau VBA ne me permet pas d'obtenir ce que je voudrai.
L'import des données des classeurs se passe bien mais l'entête n'est importée que sur la 1er colonne en A1, comment faire pour l'importer sur les autres colonnes ?
Ca c'est la partie simple, idéalement l'entête est en D1 sur les classeurs et les données en B3:B300, l'import de la compilation serait en Ligne 1 sur les colonnes pour les entêtes et à partir de la ligne2 pour les données sur les colonnes en fonction du nombre de classeurs externes. (ça fonctionne déjà mais pas au bon endroit).
Si vous n'avez pas le temps je me contenterai du simple ,-)

Merci beaucoup
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 ' copie les datas des classeurs externes dans ce classeur en creant un onglet Import Sub consolide() ChDir ThisWorkbook.Path Set classeurMaitre = ThisWorkbook ' sup i = 0 compteur = 0 'Ajoute une feuille à ce classeur Set feuille = classeurMaitre.Sheets.Add(After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)) feuille.Name = "Import" 'parcourir les classeurs de ce répertoire nf = Dir("*.xls") Do While nf <> "" If nf <> classeurMaitre.Name Then compteur = compteur + i Workbooks.Open Filename:=nf With ActiveWorkbook.Sheets(1).UsedRange If compteur = 1 Then 'si compteur = 1 copie avec la ligne d'entête de la plage .Copy Destination:=feuille.Cells(Rows.Count, 1).End(xlUp) Else 'sinon copie sans l'entête With .Offset(1).Resize(.Rows.Count, 1) .Copy Destination:=feuille.Cells(Rows.Count, i).End(xlUp).Offset(1, 0) End With End If End With Workbooks(nf).Close False End If nf = Dir i = i + 1 Loop End Sub

10/12/2018, 09h47
MarcelG

Bonjour et bienvenu sur le Forum,

Des redondances au niveau des variables
"classeurmaitre" et "feuille" ne servent à rien.
i et compteur peuvent se résumer en une seule variable.
La méthode Resize semble mal argumentée.
Afin d'évier les répétitions d'objet, le bloc With doit être utilisé.
Je te conseille également de contrôler l' adresse des objets range utilisés (Debug.Print...)

Tu peux consulter cet espace documentaire sur l' objet Range
10/12/2018, 11h28
patricktoulon

re

bonjour
j'ajouterais que dir te renvoie les noms des fichiers alors workbooks.open(nf) c'est walouhh il te faut le chemin complet

Bonjour
Merci de ta réponse malgré ta bonne volonté cela ne m'aide pas beaucoup, je ne sais pas programmer en VBA seulement parfois adapter le code, je ne sais plus ou j'avais trouvé celui-ci mais après adaptation je peux m'en contenter.
Il y a un phénomène que je rencontre qui est peut être du à ce que tu écris ? en effet suivant le répertoire ou je mets les fichiers il ne va pas chercher les bons classeurs et même des xlsx alors que l'on impose que des xls
Je pensait que ThisWorkbook.Path imposait le chemin (?).

Voici mon code modifié mais ne fait qu'incrémenter les colonnes au bon endroit quand ça marche...
Merci encore de ton aide

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
' copie les datas des classeur dans ce classeur en creant un onglet Import
Sub Consolidation_notes_votes()
  ' efface feuille import
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Import").Delete
    Application.DisplayAlerts = True
  '------------------------------------
 
      ChDir ThisWorkbook.Path
  Set classeurMaitre = ThisWorkbook
 ' sup
 i = 0
  compteur = 0
  'Ajoute une feuille à ce classeur
  Set feuille = classeurMaitre.Sheets.Add(After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count))
feuille.Name = "Import"
 
   'parcourir les classeurs de ce répertoire
  nf = Dir("*.xls")
  Do While nf <> ""
    If nf <> classeurMaitre.Name Then
      compteur = compteur + i
      Workbooks.Open Filename:=nf
      With ActiveWorkbook.Sheets(1).UsedRange
      If compteur = 1 Then
            'si compteur = 1 copie avec la ligne d'entête de la plage
          '' .Copy Destination:=feuille.Cells(Rows.Count, 1).End(xlUp)
          .Copy Destination:=feuille.Cells(Rows.Count, 1).End(xlUp).Offset(0, 0)
      Else
            'sinon copie sans l'entête
            .Copy Destination:=feuille.Cells(Rows.Count, i).End(xlUp).Offset(0, 0)
          With .Offset(1).Resize(.Rows.Count, 1)
           ''  .Copy Destination:=feuille.Cells(Rows.Count, i).End(xlUp).Offset(1, 0)
            End With
        End If
      End With
      Workbooks(nf).Close False
  End If
    nf = Dir
 
    i = i + 1
 
  Loop
 
End Sub

re
analyse ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
' copie les datas des classeurs externes dans ce classeur en creant un onglet Import
Sub consolide()
    Dim chemin$, cel As Range, Sh As Worksheet, Nf, x&
    chemin = ThisWorkbook.Path & "\"
    Set wbk1 = ThisWorkbook
    Set Sh = wbk1.Sheets.Add(After:=wbk1.Sheets(wbk1.Sheets.Count))
    Sh.Name = "Import"
    Nf = Dir("*.xls")
    Do While Nf <> ""
        If Nf <> wbk1.Name Then
            x = x + 1
            Set cel = IIf(x = 1, Sh.Range("A1"), Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1))
            With Workbooks.Open(Filename:=chemin & Nf)
                .Sheets(1).UsedRange.Copy Destination:=cel
                .Close False
            End With
        End If
        Nf = Dir
    Loop
End Sub

10/12/2018, 11h47
re

Citation:

Envoyé par patricktoulon

bonjour
j'ajouterais que dir te renvoie les noms des fichiers alors workbooks.open(nf) c'est walouhh il te faut le chemin complet

Oui certainement, si j'ai bien compris mais le but c'est de ne pas rentrer le chemin complet pour que l'on puisse l'utiliser sur divers pc ou répertoire, l'idée que ça cherche que ees classeurs du répertoire courant me convient bien
10/12/2018, 11h51
re

EDIT
Je viens de changer le nom du fichier, ça fonctionne (pourquoi ?) mais il faudrait que ça s'affiche sur les colonne suivantes suivant le classeur qui s'ouvre
Ta macro est plus simple ,-)

Je ne comprends pas ce qui se passe, ça va chercher un nom de classeur qui est dans un autre répertoire et comme il n'est pas dans le répertoire courant il y a un erreur

re
je repete dou.........cement , len....tement

nf dans ta boucle dir te renvoie le nom du classeur
c'est a dire que :
si tu a un fichier "toto.xls" dans ton dossier il te renvoie "toto.xls"

quand tu fait
workbooks.open nf tu fait workbooks.open "toto.xls" ca ne peut donc pas fonctionner car pour l'ouvrir il faut le chemin complet
exemple "C:\mondossier\un sous dossier\toto.xls"
j'avais moi meme oublié de corriger une ligne dans ton code
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 ' copie les datas des classeurs externes dans ce classeur en creant un onglet Import Sub consolide() Dim chemin$, cel As Range, Sh As Worksheet, Nf, x&,wbk1 as workbook chemin = ThisWorkbook.Path & "\" Set wbk1 = ThisWorkbook Set Sh = wbk1.Sheets.Add(After:=wbk1.Sheets(wbk1.Sheets.Count)) Sh.Name = "Import" Nf = Dir(chemin & "*.xls") Do While Nf <> "" If Nf <> wbk1.Name Then x = x + 1 Set cel = IIf(x = 1, Sh.Range("A1"), Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)) With Workbooks.Open(Filename:=chemin & Nf) .Sheets(1).UsedRange.Copy Destination:=cel .Close False End With End If Nf = Dir Loop End Sub
voila cogite la dessus ;)

le repertoire courant tu le force avec chdir thisworkbook.path a quoi ca te sert !!!!??????
donc chemin=thisworkbook.path & "\"

Merci beaucoup, j'ai réussi à adapter
ici : Set cel = IIf(x = 1, Sh.Range("A1"), Sh.Cells(Rows.Count, x).End(xlUp).Offset(0))
Très bonne journée

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
' copie les datas des classeurs externes dans ce classeur en creant un onglet Import
Sub consolide()
 
'-------------------------------------
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Import").Delete
    Application.DisplayAlerts = True
  '------------------------------------
 
    Dim chemin$, cel As Range, Sh As Worksheet, Nf, x&, wbk1 As Workbook
    chemin = ThisWorkbook.Path & "\"
    Set wbk1 = ThisWorkbook
    Set Sh = wbk1.Sheets.Add(After:=wbk1.Sheets(wbk1.Sheets.Count))
    Sh.Name = "Import"
    Nf = Dir(chemin & "*.xls")
    Do While Nf <> ""
        If Nf <> wbk1.Name Then
            x = x + 1
                      Set cel = IIf(x = 1, Sh.Range("A1"), Sh.Cells(Rows.Count, x).End(xlUp).Offset(0))
            With Workbooks.Open(Filename:=chemin & Nf)
                .Sheets(1).UsedRange.Copy Destination:=cel
                .Close False
            End With
        End If
        Nf = Dir
 
    Loop
End Sub

10/12/2018, 12h26
patricktoulon

re

re
de rien clique sur résolu dans ce cas la ;)
18/12/2018, 19h05
re

Edit
A ne rien y comprendre, j'ai tout copié dans un autre répertoire et ça refonctionne... ,-(

Bonsoir,
J'ai encore besoin de vous, je ne sais pas pourquoi ça n'ouvre que 3 fichiers alors que j'ai 5 fichiers *.xls tous identiques mais avec des noms différents.
Nf s’incrémente jusqu' au fichier 3 puis devient "" et puis End sub.

Avez-vous une idée ? je n'ai rien changé dans les fichiers

Merci