Transformer données en tableaux

Bonjour,

J'ai un fichier Excel composé d'une macro qui me permet de récupérer des données issues d'un autre Excel pour les collés dans la feuille voulu de mon fichier. Cela est fonctionnel. Ce que je veux maintenant c'est que les informations récupérés soit directement sous forme de tableau afin de pouvoir utiliser plus facilement les informations.

Merci de votre aide,

Mon code est le suivant :

Sub Rectangleàcoinsarrondis1_Cliquer()

Dim objOuvrir As FileDialog
Dim objFichiers As FileDialogSelectedItems
Dim wbsource As Workbook, wbdest As Workbook

Set objOuvrir = Application.FileDialog(msoFileDialogOpen)

With objOuvrir 'Affiche la fenêtre "Ouvrir"
.Filters.Clear 'Efface les filtres existants.
.Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm" 'Définit une liste de filtres pour le champ "Type de fichiers".
.Show
Set objFichiers = .SelectedItems 'Définit les fichiers sélectionnés
End With

Worksheets("Armoires").Range("A2:BZ5000").ClearContents
Worksheets("Supports + Foyers").Range("A2:FA5000").ClearContents

If Not objFichiers.Count = 1 Then Exit Sub 'On sort si aucun fichier n'a été sélectionné

Application.ScreenUpdating = False

Set wbdest = ThisWorkbook 'classeur exécutant où sera collée la feuille
Set wbsource = Workbooks.Open(objFichiers(1))

wbsource.Sheets("Armoire").UsedRange.Copy Destination:=wbdest.Sheets("Armoires").Range("A1") '<<<<ADAPTER
wbsource.Sheets("Support + Foyer").UsedRange.Copy Destination:=wbdest.Sheets("Supports + Foyers").Range("A1")
wbsource.Close False

Application.ScreenUpdating = True

Dim pl As Range, sh As Worksheet
For Each sh In Worksheets(Array("Armoires", "Supports + Foyers"))
Set pl = sh.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
If Not pl Is Nothing Then
Cells(Rows.Count, Columns.Count).Copy
pl.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
End If
Next sh

Fin:
End Sub

Bonjour,

Commence par créer un tableau dans ta feuille de destination wbdest.Sheets("Armoires")

Pour remettre à blanc :

If Not wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Delete

puis ajouter un élément du tableau avant de copier

            wbdest.Sheets("Armoires").ListObjects(1).ListRows.Add
            i = wbdest.Sheets("Armoires").ListObjects(1).ListRows.Count

enfin copier sur cet élément

wbsource.Sheets("Armoire").UsedRange.Copy Destination:=wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Cells(i, 1)

par contre avec usedrange tu risques d'y amener aussi les en-têtes

Bonjour,

Merci de votre aide !

J'ai procédé comme ceci :

Sub Macro2()
'
Range("A2:BP23").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$2:$BP$23"), , xlYes).Name = _
"Tableau1"
Range("Tableau1[#All]").Select
End Sub

Le problème est que ma range en colone et en ligne est variable ( elle ne s'arrete pas forcément en BP et en 23..) Du coup comment gérer la taille des données receptionné? De plus, comment selectionner sur quel feuille appliqué cette macro ?

Bonjour,

J'ai essaye avec votre code, il y a un probleme d'incompatiblité de type concernant le wbdest.Sheets

Cdlt

Crée le tableau manuellement une fois pour toutes.

Pour l'incompatibilité, il faudrait que je vois le projet > le tableau a-t-il bien été créé ?, idem pour les colonnes variables (pour les lignes, le tableau s'adaptera).

On peut partir d'un tableau à une seule colonne, il créera les nouvelles colonnes sas soucis si les en-têtes sont bien toutes présentes.

Bonjour,

En créant le tableau ca ne fonctionne toujours pas. Pas de problème pour les en-têtes, il me les faut !

Ci joint le projet ( testenregistreur) avec un fichier test à ouvrir.

Merci de votre aide,

Hum ... cellule fusionnée ! dans l'import cela n'arrange jamais ! surtout pas en copie.

de plus ton projet est en rouge ! ne peut pas fonctionner !!!

Je n'ai pas adapté le nombre de colonnes pour le moment ... essai déjà ceci (attention, je n'ai fait que Armoires)

Sub Rectangleàcoinsarrondis1_Cliquer()

Dim objOuvrir As FileDialog
Dim objFichiers As FileDialogSelectedItems
Dim wbsource As Workbook, wbdest As Workbook
Dim rng As Range

Set objOuvrir = Application.FileDialog(msoFileDialogOpen)

With objOuvrir 'Affiche la fenêtre "Ouvrir"
    .Filters.Clear 'Efface les filtres existants.
    .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm" 'Définit une liste de filtres pour le champ "Type de fichiers".
    .Show
    Set objFichiers = .SelectedItems 'Définit les fichiers sélectionnés
End With
If Not objFichiers.Count = 1 Then Exit Sub 'On sort si aucun fichier n'a été sélectionné

Application.ScreenUpdating = False

Set wbdest = ThisWorkbook 'classeur exécutant où sera collée la feuille
Set wbsource = Workbooks.Open(objFichiers(1))

    If Not wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Delete
    wbdest.Sheets("Armoires").ListObjects(1).ListRows.Add
    I = wbdest.Sheets("Armoires").ListObjects(1).ListRows.Count
    Set rng = wbsource.Sheets("Armoire").Range("A1").CurrentRegion
    Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 2, Columns.Count) ' pour enlever le super titre fusionné et l'en-tête
    rng.Copy Destination:=wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Cells(I, 1)

wbsource.Close False

Application.ScreenUpdating = True

Fin:
End Sub

désolé, j'ai dû effacer quelques calculs de la première page, mais c'est le principe d'importation, que je voulais te montrer.

Bonjour,

Ca marche parfaitement merci !! J'essaye de le faire tout seul pour l'autre onglet.

Si vous avez une idée pour adapter les colonnes ce serait parfait sinon pas de problème, votre aide m'a déja été précieuse!

Cdlt

Bonjour,

Comment faire pour que ca fonctionne aussi pour l'onglet Supports + Foyers ?

Merci d'avance,

Cdlt

clemroussi a écrit :

Bonjour,

Ca marche parfaitement merci !! J'essaye de le faire tout seul pour l'autre onglet.

Si vous avez une idée pour adapter les colonnes ce serait parfait sinon pas de problème, votre aide m'a déja été précieuse!

Cdlt

Tu dupliques ...

Set wbdest = ThisWorkbook 'classeur exécutant où sera collée la feuille
Set wbsource = Workbooks.Open(objFichiers(1))

If Not wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Delete
    wbdest.Sheets("Armoires").ListObjects(1).ListRows.Add
    I = wbdest.Sheets("Armoires").ListObjects(1).ListRows.Count
    Set rng = wbsource.Sheets("Armoire").Range("A1").CurrentRegion
    Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 2, Columns.Count) ' pour enlever le super titre fusionné et l'en-tête
    rng.Copy Destination:=wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Cells(I, 1)

If Not wbdest.Sheets("xxx").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("xxx").ListObjects(1).DataBodyRange.Delete
    wbdest.Sheets("xxx").ListObjects(1).ListRows.Add
    I = wbdest.Sheets("xxx").ListObjects(1).ListRows.Count
    Set rng = wbsource.Sheets("xxx").Range("A1").CurrentRegion
    Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 2, Columns.Count) ' pour enlever le super titre fusionné et l'en-tête
    rng.Copy Destination:=wbdest.Sheets("xxx").ListObjects(1).DataBodyRange.Cells(I, 1)

wbsource.Close False

en remplaçant xxx par le nom de l'autre onglet

Crée d'abord un tableau avec toutes les colonnes.

Bonjour,

Oui oui je l'ai fais ! Lors de l'execution de la macro la première fois tout fonctionne !

Le problème est que lorsque j'execute une seconde fois ma macro, l'onglet Armoire devient vide, et les données receptionné vont se mettre à la suite des précédentes dans l'onglet Supports + Foyers. Je souhaiterais écraser les données précédentes si j'execute une seconde fois ma macro !

A par cela, tout fonctionne parfaitement..

Encore merci de votre aide,

Cdlt

Tes onglets n'ont pas le même nom des 2 côtés !

En corrigeant le nom de l'onglet

    If Not wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Delete
    wbdest.Sheets("Armoires").ListObjects(1).ListRows.Add
    I = wbdest.Sheets("Armoires").ListObjects(1).ListRows.Count
    Set rng = wbsource.Sheets("Armoire").Range("A1").CurrentRegion
    Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 2, Columns.Count) ' pour enlever le super titre fusionné et l'en-tête
    rng.Copy Destination:=wbdest.Sheets("Armoires").ListObjects(1).DataBodyRange.Cells(I, 1)

    If Not wbdest.Sheets("Support + Foyer").ListObjects(1).DataBodyRange Is Nothing Then wbdest.Sheets("Support + Foyer").ListObjects(1).DataBodyRange.Delete
    wbdest.Sheets("Support + Foyer").ListObjects(1).ListRows.Add
    I = wbdest.Sheets("Support + Foyer").ListObjects(1).ListRows.Count
    Set rng = wbsource.Sheets("Support + Foyer").Range("A1").CurrentRegion
    Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 2, Columns.Count) ' pour enlever le super titre fusionné et l'en-tête
    rng.Copy Destination:=wbdest.Sheets("Support + Foyer").ListObjects(1).DataBodyRange.Cells(I, 1)

edit : code corrigé

Dans votre exemple, les données copiés dans l'onglet Armoires et Supports + Foyers sont exactement les mêmes. Ce n'est pas ce que je veux, mais j'ai réussis à adapter pour que sa fonctionne !!!

Il faudrait si possible gérer les colones..

Merci

Oui désolé, j'avais oublié un remplacement ici (mais il était facile de recopier comme demandé plus haut).

wbsource.Sheets("Armoire")

yes merci !

clemroussi a écrit :

Il faudrait si possible gérer les colones..

Comme ceci

edit : fichier supprimé corrigé

Bonjour,

Merci de ta réponse. Ton fichier me créer des colonnes jusqu'à la colonne XFD ! Il ne s'arrête pas au nombre de colonne de mon fichier ou je récupère les données.

Cdlt