Faire une compilation de tableau

auverland · 26 Mars 2014

Bonjour a tous

Je souhaite faire un récap de différents tableau/fichier et le top qu'il parcourt l'intégralité des sous répertoir par rapport à son emplacement

Ci joint le fichier type "récap Méto site" que j'aimerais obtenir

Chaque fichier de donnés "Méto site XXX" sont iddentique en onglet et format d'onglet
_ grossierement supression des deux premieres ligne du fichier
_ récupereation du tableau résultat
_ récupération des cellule #ref! de chaque paragraphe ex "B7" sur cuillière

Pour tout coller les uns a coté des autres sur récap en indiquant le nom du fichier en haut de chaque résultat

Merci pour votre aide
Auverland

Robert · 26 Mars 2014

Re : Faire une compilation de tableau

Bonsoir Auverland, bonsoir le forum,

Le code à placer dans le classeur recap Méto site.xls :

Code:

Sub Macro1()
Dim cd As Workbook 'déclare la variable cd (Classeur Destination)
Dim od1 As Object 'déclare la variable od1 (Onglet Destination 1)
Dim od2 As Object 'déclare la variable od2 (Onglet Destination 2)
Dim od3 As Object 'déclare la variable od3 (Onglet Destination 3)
Dim ch As String 'déclare la variable ch (CHemin)
Dim sf As Object 'déclare la variable sf (Système de Fichiers)
Dim d As Object 'déclare la variable d (Dossier)
Dim o As Object 'déclare la variable o (Onglets)
Dim fs As Object 'déclare la variable fs (FichierS)
Dim f As Object 'déclare la variable f (Fichier)
Dim cs As Workbook 'déclare la variable cs (Classeur Source)
Dim os1 As Object 'déclare la variable os (Onglet Source 1)
Dim os2 As Object 'déclare la variable os (Onglet Source 2)
Dim os3 As Object 'déclare la variable os (Onglet Source 3)
Dim dest1 As Range 'déclare la variable dest1 (cellule de DESTination 1)
Dim dest2 As Range 'déclare la variable dest2 (cellule de DESTination 2)
Dim dest3 As Range 'déclare la variable dest3 (cellule de DESTination 3)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set cd = ThisWorkbook 'définit le classeur destination cd
ch = cd.Path 'définit la chemin
Set od1 = cd.Sheets("Récap cuilliere") 'définit l'onglet de destination od1
Set od2 = cd.Sheets("Récap couteau") 'définit l'onglet de destination od2
Set od3 = cd.Sheets("Récap Fourchettes") 'définit l'onglet de destination od3
'suppression des anciennes données
od1.Range("E1:" & od1.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od2.Range("E1:" & od2.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od3.Range("E1:" & od3.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
Set sf = CreateObject("Scripting.FileSystemObject") 'définit la variable sf
Set d = sf.getfolder(ch) 'définit la variable d
Set fs = d.Files 'définit la variable fs
For Each f In fs 'boucles sur touts les fichiers du dossier d
    'condition : si le fichier f à une extension ".xls" et commence par "Méto site"
    If Right(f.Name, 4) = ".xls" And Left(f.Name, 9) = "Méto site" Then
        'définit dest1 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest1 = IIf(od1.Range("E3").Value = "", od1.Range("E3"), od1.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        'définit dest2 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 3 colonnes à droite)
        Set dest2 = IIf(od2.Range("E3").Value = "", od2.Range("E3"), od2.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 3))
        'définit dest3 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest3 = IIf(od3.Range("E3").Value = "", od3.Range("E3"), od3.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        Workbooks.Open f 'ouvre le fichier
        Set cs = ActiveWorkbook 'définit le classeur source cs
        Set os1 = cs.Sheets("cuilliere") 'définit l'onglet source os1
        Set os2 = cs.Sheets("couteau") 'définit l'onglet source os2
        Set os3 = cs.Sheets("Fourchettes") 'définit l'onglet source os3
        'récap cuillères
        dest1.Value = cs.Name 'place le nom du classeur
        os1.Range("E4:I32").Copy 'copie la plage utile plus une colonne
        dest1.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os1.Range("E4:H32").Copy dest1.Offset(1, 0) 'copie/colle la plage utile
        dest1.Offset(4, 0).Value = os1.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest1.Offset(13, 0).Value = os1.Range("B16").Value 'récupère le nom correspondant à Vita B
        dest1.Offset(23, 0).Value = os1.Range("B26").Value 'récupère le nom correspondant à Vita C
        'récap couteaux
        dest2.Value = cs.Name 'place le nom du classeur
        os2.Range("E4:G43").Copy 'copie la plage utile plus une colonne
        dest2.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os2.Range("E4:F43").Copy dest2.Offset(1, 0) 'copie/colle la plage utile
        dest2.Offset(4, 0).Value = os2.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(15, 0).Value = os2.Range("B18").Value 'récupère le nom correspondant à Vita b
        dest2.Offset(26, 0).Value = os2.Range("B29").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(37, 0).Value = os2.Range("B40").Value 'récupère le nom correspondant à Inter MAR
        'récap fourchettes
        dest3.Value = cs.Name 'place le nom du classeur
        os3.Range("E4:I35").Copy 'copie la plage utile plus une colonne
        dest3.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os3.Range("E4:H35").Copy dest3.Offset(1, 0) 'copie/colle la plage utile
        dest3.Offset(4, 0).Value = os3.Range("B7").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(13, 0).Value = os3.Range("B16").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(25, 0).Value = os3.Range("B28").Value 'récupère le nom correspondant à Vita b
        cs.Close 'ferme le classeur de données
    End If 'fin de la condition
Next f 'prochain classeur de la boucle
od3.Select: Range("A1").Select 'sélectionne la cellule A1
od2.Select: Range("A1").Select 'sélectionne la cellule A1
od1.Select: Range("A1").Select 'sélectionne la cellule A1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Bien entendu, tous les fichiers doivent se trouver dans la même dossier que recap Méto site.xls...

auverland · 27 Mars 2014

Re : Faire une compilation de tableau

C'est géniale, merci beaucoup pour votre gentillesse. Tout seul j'aurais vraiment abandonné l'idée

En plus avec tout les commentaires pour bien comprendre le cheminement.

Je vais maintenant essayer de le completer à mon besoin final.

auverland · 27 Mars 2014

Re : Faire une compilation de tableau

Bonjour,

J'ai souhaité intégrer une condition suplementaire pour un onglet dans le cas d'un format spécial
type :
Workbooks.Open f 'ouvre le fichier
Set cs = ActiveWorkbook 'définit le classeur source cs
Set os1 = cs.Sheets("cuilliere") 'définit l'onglet source os1
Set os2 = cs.Sheets("couteau") 'définit l'onglet source os2
Set os3 = cs.Sheets("Fourchettes") 'définit l'onglet source os3

If cs.Sheets("cuilliere").Range("B7").Value = "toto" Then
'récap cuillères
dest1.Value = cs.Name 'place le nom du classeur
os1.Range("f4:j32").Copy 'copie la plage utile plus une colonne
dest1.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
os1.Range("f4:i32").Copy dest1.Offset(1, 0) 'copie/colle la plage utile
dest1.Offset(4, 0).Value = os1.Range("B7").Value 'récupère le nom correspondant à Vita A
dest1.Offset(13, 0).Value = os1.Range("B16").Value 'récupère le nom correspondant à Vita B
dest1.Offset(23, 0).Value = os1.Range("B26").Value 'récupère le nom correspondant à Vita C
Else
'récap cuillères
dest1.Value = cs.Name 'place le nom du classeur
os1.Range("E4:I32").Copy 'copie la plage utile plus une colonne
dest1.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
..............
end if
je me retrouve avec l' Erreur d'execution 13 lors du traitement du deuxieme fichier

c'est quoi comme type d'erreur ?
Merci

Robert · 27 Mars 2014

Re : Faire une compilation de tableau

Bonjour Auverland, bonjour le forum,

Pas très clair... J'ai modifié le code en utilisant une variable plc. regarde si ça convient :

Code:

Sub Macro1()
Dim cd As Workbook 'déclare la variable cd (Classeur Destination)
Dim od1 As Object 'déclare la variable od1 (Onglet Destination 1)
Dim od2 As Object 'déclare la variable od2 (Onglet Destination 2)
Dim od3 As Object 'déclare la variable od3 (Onglet Destination 3)
Dim ch As String 'déclare la variable ch (CHemin)
Dim sf As Object 'déclare la variable sf (Système de Fichiers)
Dim d As Object 'déclare la variable d (Dossier)
Dim o As Object 'déclare la variable o (Onglets)
Dim fs As Object 'déclare la variable fs (FichierS)
Dim f As Object 'déclare la variable f (Fichier)
Dim cs As Workbook 'déclare la variable cs (Classeur Source)
Dim os1 As Object 'déclare la variable os (Onglet Source 1)
Dim os2 As Object 'déclare la variable os (Onglet Source 2)
Dim os3 As Object 'déclare la variable os (Onglet Source 3)
Dim dest1 As Range 'déclare la variable dest1 (cellule de DESTination 1)
Dim dest2 As Range 'déclare la variable dest2 (cellule de DESTination 2)
Dim dest3 As Range 'déclare la variable dest3 (cellule de DESTination 3)
Dim plc As Range 'déclare la variable plc (PLage sous Condition)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set cd = ThisWorkbook 'définit le classeur destination cd
ch = cd.Path 'définit la chemin
Set od1 = cd.Sheets("Récap cuilliere") 'définit l'onglet de destination od1
Set od2 = cd.Sheets("Récap couteau") 'définit l'onglet de destination od2
Set od3 = cd.Sheets("Récap Fourchettes") 'définit l'onglet de destination od3
'suppression des anciennes données
od1.Range("E1:" & od1.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od2.Range("E1:" & od2.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od3.Range("E1:" & od3.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
Set sf = CreateObject("Scripting.FileSystemObject") 'définit la variable sf
Set d = sf.getfolder(ch) 'définit la variable d
Set fs = d.Files 'définit la variable fs
For Each f In fs 'boucles sur touts les fichiers du dossier d
    'condition : si le fichier f à une extension ".xls" et commence par "Méto site"
    If Right(f.Name, 4) = ".xls" And Left(f.Name, 9) = "Méto site" Then
        'définit dest1 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest1 = IIf(od1.Range("E3").Value = "", od1.Range("E3"), od1.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        'définit dest2 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 3 colonnes à droite)
        Set dest2 = IIf(od2.Range("E3").Value = "", od2.Range("E3"), od2.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 3))
        'définit dest3 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest3 = IIf(od3.Range("E3").Value = "", od3.Range("E3"), od3.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        Workbooks.Open f 'ouvre le fichier
        Set cs = ActiveWorkbook 'définit le classeur source cs
        Set os1 = cs.Sheets("cuilliere") 'définit l'onglet source os1
        Set os2 = cs.Sheets("couteau") 'définit l'onglet source os2
        Set os3 = cs.Sheets("Fourchettes") 'définit l'onglet source os3
        Set plc = IIf(os1.Range("B7").Value = "toto", os1.Range("F4:I32"), os1.Range("E4:H32")) 'définit la plage plc (à adapter car j'ai pas bien compris)
        'récap cuillères
        dest1.Value = cs.Name 'place le nom du classeur
        plc.Resize(plc.Rows.Count, plc.Columns.Count + 1).Copy 'copie la plage plc plus une colonne
        dest1.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        plc.Copy dest1.Offset(1, 0) 'copie/colle la plage plc
        dest1.Offset(4, 0).Value = os1.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest1.Offset(13, 0).Value = os1.Range("B16").Value 'récupère le nom correspondant à Vita B
        dest1.Offset(23, 0).Value = os1.Range("B26").Value 'récupère le nom correspondant à Vita C
        'récap couteaux
        dest2.Value = cs.Name 'place le nom du classeur
        os2.Range("E4:G43").Copy 'copie la plage utile plus une colonne
        dest2.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os2.Range("E4:F43").Copy dest2.Offset(1, 0) 'copie/colle la plage utile
        dest2.Offset(4, 0).Value = os2.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(15, 0).Value = os2.Range("B18").Value 'récupère le nom correspondant à Vita b
        dest2.Offset(26, 0).Value = os2.Range("B29").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(37, 0).Value = os2.Range("B40").Value 'récupère le nom correspondant à Inter MAR
        'récap fourchettes
        dest3.Value = cs.Name 'place le nom du classeur
        os3.Range("E4:I35").Copy 'copie la plage utile plus une colonne
        dest3.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os3.Range("E4:H35").Copy dest3.Offset(1, 0) 'copie/colle la plage utile
        dest3.Offset(4, 0).Value = os3.Range("B7").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(13, 0).Value = os3.Range("B16").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(25, 0).Value = os3.Range("B28").Value 'récupère le nom correspondant à Vita b
        cs.Close 'ferme le classeur de données
    End If 'fin de la condition
Next f 'prochain classeur de la boucle
od3.Select: Range("A1").Select 'sélectionne la cellule A1
od2.Select: Range("A1").Select 'sélectionne la cellule A1
od1.Select: Range("A1").Select 'sélectionne la cellule A1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

auverland · 27 Mars 2014

Re : Faire une compilation de tableau

Bonjour,
Il met le même code "ereur execution13 incompatibilité de type" au traitement du deuxieme fichier juste après les lignes : (execution pas à pas )

Set os1 = cs.Sheets("cuilliere") 'définit l'onglet source os1
Set os2 = cs.Sheets("couteau") 'définit l'onglet source os2
Set os3 = cs.Sheets("Fourchettes") 'définit l'onglet source os3

Robert · 27 Mars 2014

Re : Faire une compilation de tableau

Bonjour Auverland, bonjour le forum,

Ce numéro d'erreur indique que l'indice n'appartient pas à la sélection. Vérifie le nom des onglets du second fichiers. Il faut qu'il soit exactement identique à couteau. Pas un espace en plus au début ou à la fin, pas un x à la fin.

auverland · 27 Mars 2014

Re : Faire une compilation de tableau

Robert à dit:
Bonjour Auverland, bonjour le forum,

Ce numéro d'erreur indique que l'indice n'appartient pas à la sélection. Vérifie le nom des onglets du second fichiers. Il faut qu'il soit exactement identique à couteau. Pas un espace en plus au début ou à la fin, pas un x à la fin.

c'est justement ce que je comprend pas, j'utilise exactement mêmes fichiers...
La premiere macro que tu as concocté est collé dans mon fichier "recap Méto site.xls" en macro1 ca fonctionne nikel
La deuxieme je la colle aussi dans ce même fichier en macro2 et la ça beug !!!

Incompatibilité de type

auverland · 27 Mars 2014

Re : Faire une compilation de tableau

Je pense avoir compris

Mon fichier n'etant pas à jour en liaison (je bloque la mise à jour) la cellule B7 est #ref du coup vba ne peux connaitre sa valeur. d'ou ce code d'ereur

Merci de votre aide

auverland · 31 Mars 2014

Re : Faire une compilation de tableau

Bonjour a tous,

Deux nouveau petit soucis, je cherche juste les 2 commandes qui permettent de :

- controle la presence de l'onglet

- Je cherche la même fonction avec contient ("cuilliere") et non est ("cuilliere") pour la ligne :
Set os1 = cs.Sheets("cuilliere") 'définit l'onglet source os1

Merci et bone semaine

Robert · 31 Mars 2014

Re : Faire une compilation de tableau

Bonjour Auverland, bonjour le forum,

Peut-être comme ça :

Code:

Dim os1 As Object
Dim sh As Object

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set os1 = Sheets("cuilliere") 'définit l'onglet o (génère une erreur si l'onglet "test" n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err = 0 'annule l'erreur
    For Each sh In Sheets 'boucle   sur tous les onglets du classeur
        If sh.Name Like "*cuilliere*" Then 'condition : si le nom de l'onglet contient "cuilliere"
            Set os1 = sh 'définit l'onglet os1
            Exit For 'sort de la boucle
        End If 'fin de la condition
    Next sh 'prochain onglet de la boucle
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs

auverland · 3 Avril 2014

Re : Faire une compilation de tableau

Merci Robert ca marche bien
par contre ca ne gère pas un onglet absent
j'ai trouvé la macro pour mais j'arrive pas à mixer les deux

Sub Absence_Onglet()
On Error Resume Next
Err = 0
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Nom de l'onglet à créer"
If Err <> 0 Then
application.displayalerts=false
activesheet.delete 'détruit la feuille créée
application.displayalerts=true
End If
End Sub

Dim os1 As Object
Dim sh As Object

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set os1 = Sheets("cuilliere") 'définit l'onglet o (génère une erreur si l'onglet "test" n'existe pas)
Set os2 = Sheets("couteau") 'définit l'onglet o (génère une erreur si l'onglet "test" n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
Err = 0 'annule l'erreur
For Each sh In Sheets 'boucle sur tous les onglets du classeur
If sh.Name Like "*cuilliere*" Then 'condition : si le nom de l'onglet contient "cuilliere"
Set os1 = sh 'définit l'onglet os1
Exit For 'sort de la boucle
Else
If sh.Name Like "*cuilliere*" Then 'condition : si le nom de l'onglet contient "cuilliere"
Set os1 = sh 'définit l'onglet os1
Exit For 'sort de la boucle
End If 'fin de la condition
Next sh 'prochain onglet de la boucle
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs.

Merci pour votre aide

Robert · 3 Avril 2014

Re : Faire une compilation de tableau

Bonsoir Auverland, bonsoir le forum,

J'ai pas bien compris où tu veux en venir. Essaie d'être un petit plus explicite...
Le code ci-dessous recherche si le classeur possède un onglet dont le nom contient "cuilliere". S'il n'en trouve pas, il crée un nouvel onglet et le nomme "cuilliere" (voir la partie entre les lignes 46 à 63).

Code:

Sub Macro1()
Dim cd As Workbook 'déclare la variable cd (Classeur Destination)
Dim od1 As Object 'déclare la variable od1 (Onglet Destination 1)
Dim od2 As Object 'déclare la variable od2 (Onglet Destination 2)
Dim od3 As Object 'déclare la variable od3 (Onglet Destination 3)
Dim ch As String 'déclare la variable ch (CHemin)
Dim sf As Object 'déclare la variable sf (Système de Fichiers)
Dim d As Object 'déclare la variable d (Dossier)
Dim o As Object 'déclare la variable o (Onglets)
Dim fs As Object 'déclare la variable fs (FichierS)
Dim f As Object 'déclare la variable f (Fichier)
Dim cs As Workbook 'déclare la variable cs (Classeur Source)
Dim os1 As Object 'déclare la variable os (Onglet Source 1)
Dim os2 As Object 'déclare la variable os (Onglet Source 2)
Dim os3 As Object 'déclare la variable os (Onglet Source 3)
Dim dest1 As Range 'déclare la variable dest1 (cellule de DESTination 1)
Dim dest2 As Range 'déclare la variable dest2 (cellule de DESTination 2)
Dim dest3 As Range 'déclare la variable dest3 (cellule de DESTination 3)
Dim plc As Range 'déclare la variable plc (PLage sous Condition)
Dim test As Boolean 'décalre la variable test

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set cd = ThisWorkbook 'définit le classeur destination cd
ch = cd.Path 'définit la chemin
Set od1 = cd.Sheets("Récap cuilliere") 'définit l'onglet de destination od1
Set od2 = cd.Sheets("Récap couteau") 'définit l'onglet de destination od2
Set od3 = cd.Sheets("Récap Fourchettes") 'définit l'onglet de destination od3
'suppression des anciennes données
od1.Range("E1:" & od1.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od2.Range("E1:" & od2.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
od3.Range("E1:" & od3.Cells(5, Application.Columns.Count).Address(0, 0)).EntireColumn.Delete 'supprime les colonnes E à... dernière
Set sf = CreateObject("Scripting.FileSystemObject") 'définit la variable sf
Set d = sf.getfolder(ch) 'définit la variable d
Set fs = d.Files 'définit la variable fs
For Each f In fs 'boucles sur touts les fichiers du dossier d
    'condition : si le fichier f à une extension ".xls" et commence par "Méto site"
    If Right(f.Name, 4) = ".xls" And Left(f.Name, 9) = "Méto site" Then
        'définit dest1 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest1 = IIf(od1.Range("E3").Value = "", od1.Range("E3"), od1.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        'définit dest2 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 3 colonnes à droite)
        Set dest2 = IIf(od2.Range("E3").Value = "", od2.Range("E3"), od2.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 3))
        'définit dest3 (E3 si E3 est vide, sinon la première colonne vide de la ligne 3 décalée de 5 colonnes à droite)
        Set dest3 = IIf(od3.Range("E3").Value = "", od3.Range("E3"), od3.Cells(3, Application.Columns.Count).End(xlToLeft).Offset(0, 5))
        Workbooks.Open f 'ouvre le fichier
        Set cs = ActiveWorkbook 'définit le classeur source cs
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set os1 = Sheets("cuilliere") 'définit l'onglet o (génère une erreur si l'onglet "test" n'existe pas)
        If Err <> 0 Then 'condition : si une erreur a été générée
            Err = 0 'annule l'erreur
            For Each sh In Sheets 'boucle   sur tous les onglets du classeur
                If sh.Name Like "*cuilliere*" Then 'condition : si le nom de l'onglet contient "cuilliere"
                    Set os1 = sh 'définit l'onglet os1
                    test = True
                    Exit For 'sort de la boucle
                 End If
            Next sh 'prochain onglet de la boucle
            If test = False Then
                ActiveWorkbook.Sheets.Add
                ActiveSheet.Name = "Cuilliere"
                Set os1 = ActiveSheet
            End If 'fin de la condition
        End If 'fin de la condition
        On Error GoTo 0 'annule la gestion des erreurs
        Set os2 = cs.Sheets("couteau") 'définit l'onglet source os2
        Set os3 = cs.Sheets("Fourchettes") 'définit l'onglet source os3
        Set plc = IIf(os1.Range("B7").Value = "toto", os1.Range("F4:I32"), os1.Range("E4:H32")) 'définit la plage plc (à adapter car j'ai pas bien compris)
        'récap cuillères
        dest1.Value = cs.Name 'place le nom du classeur
        plc.Resize(plc.Rows.Count, plc.Columns.Count + 1).Copy 'copie la plage plc plus une colonne
        dest1.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        plc.Copy dest1.Offset(1, 0) 'copie/colle la plage plc
        dest1.Offset(4, 0).Value = os1.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest1.Offset(13, 0).Value = os1.Range("B16").Value 'récupère le nom correspondant à Vita B
        dest1.Offset(23, 0).Value = os1.Range("B26").Value 'récupère le nom correspondant à Vita C
        'récap couteaux
        dest2.Value = cs.Name 'place le nom du classeur
        os2.Range("E4:G43").Copy 'copie la plage utile plus une colonne
        dest2.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os2.Range("E4:F43").Copy dest2.Offset(1, 0) 'copie/colle la plage utile
        dest2.Offset(4, 0).Value = os2.Range("B7").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(15, 0).Value = os2.Range("B18").Value 'récupère le nom correspondant à Vita b
        dest2.Offset(26, 0).Value = os2.Range("B29").Value 'récupère le nom correspondant à Vita A
        dest2.Offset(37, 0).Value = os2.Range("B40").Value 'récupère le nom correspondant à Inter MAR
        'récap fourchettes
        dest3.Value = cs.Name 'place le nom du classeur
        os3.Range("E4:I35").Copy 'copie la plage utile plus une colonne
        dest3.Offset(1, 0).PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes
        os3.Range("E4:H35").Copy dest3.Offset(1, 0) 'copie/colle la plage utile
        dest3.Offset(4, 0).Value = os3.Range("B7").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(13, 0).Value = os3.Range("B16").Value 'récupère le nom correspondant à Vita b
        dest3.Offset(25, 0).Value = os3.Range("B28").Value 'récupère le nom correspondant à Vita b
        cs.Close 'ferme le classeur de données
    End If 'fin de la condition
Next f 'prochain classeur de la boucle
od3.Select: Range("A1").Select 'sélectionne la cellule A1
od2.Select: Range("A1").Select 'sélectionne la cellule A1
od1.Select: Range("A1").Select 'sélectionne la cellule A1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

auverland · 4 Avril 2014

Re : Faire une compilation de tableau

Bonjour

Merci beaucoup Robert c'est pile poils ce qu'il me fallait

Bon week-end

Faire une compilation de tableau

auverland

XLDnaute Occasionnel

Pièces jointes

Robert

XLDnaute Barbatruc

auverland

XLDnaute Occasionnel

auverland

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

auverland

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

auverland

XLDnaute Occasionnel

auverland

XLDnaute Occasionnel

auverland

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

auverland

XLDnaute Occasionnel

Robert

XLDnaute Barbatruc

auverland

XLDnaute Occasionnel

Discussions similaires

Faire une compilation de tableau

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency