Petite modification d'un code VBA

re · 09/12/2018, 16h15

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 :

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
' 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

**MarcelG** · 10/12/2018, 09h47

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

**patricktoulon** · 10/12/2018, 11h28

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

re · 10/12/2018, 11h39

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 :

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
' 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

**patricktoulon** · 10/12/2018, 11h45

re
analyse ceci

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
' 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

re · 10/12/2018, 11h47

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

re · 10/12/2018, 11h51

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

**patricktoulon** · 10/12/2018, 11h56

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 :

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
' 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 & "\"

re · 10/12/2018, 12h24

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 :

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
' 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

**patricktoulon** · 10/12/2018, 12h26

re
de rien clique sur résolu dans ce cas la

re · 18/12/2018, 19h05

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

Petite modification d'un code VBA

Macros et VBA Excel

Partager

Partager