Report de données de feuilles vers une seul feuille

Le 30/05/2013 à 10:52

Bonjour à tous,

C'est encore moi,

Suite à mon ancien problème déjà résolus (grâce à vous ), j'essaye d'automatiser cette fois ci un transfert de données de plusieurs feuilles vers une unique feuille.

A première vue cela est simple, mais la difficulté c'est que chaque feuilles n'a pas le même nombre de lignes de cellules à transférer et ce quelque soit le nombres de feuilles.

Concrètement, j'essaye de faire du copier coller des données de chaque feuilles sur une seul feuille, avec les données l'une en dessous des autres.

Pour illustrer le problème, j'ai pris un exemple.

Le bût sur cette feuille, c'est de pouvoir transférer les données des trois premières feuilles vers la quatrième et ce quelque soit le nombre de lignes que contient chacune des trois première feuilles (il se peut que qu'il y ait plus de données sur la première feuille que sur la deuxième par exemple).

Voici ce que j'ai déjà essayé:

Sub export()

Dim k, i, j, n As Integer

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For k = 1 To Worksheets.Count - 1

n = ThisWorkbook.Worksheets(k).Cells(Rows.Count, 8).End(xlUp).Row + n

    For i = 1 To n

        For j = 1 To 3

        ThisWorkbook.Worksheets("TRANSFERT").Cells(i + n, j).Value = ThisWorkbook.Worksheets(k).Cells(i + 1, j).Value

        Next j

    Next i

Next k

End Sub

Mais ça marche pas des masses

Voilà, merci à tous de votre aide précieuse et j'espère que ce que j'ai raconté n'est pas trop confus.

37exemple.xlsm (24.57 Ko)
Le 30/05/2013 à 11:29

Ton problème se trouve ici :

m = m + 1
ThisWorkbook.Worksheets("TRANSFERT").Cells(i + n, j).Value = ThisWorkbook.Worksheets(m).Cells(i + 15, j).Value

Tu as 5 feuilles (incluant la feuille transfert; lorsque m atteint la valeur 6, la macro plante parce qu'il n'existe pas de feuille 6.

Supprime la ligne m=m+1 et remplace dans ton code ThisWorkbook.Worksheets(m) par ThisWorkbook.Worksheets(k)

Ca, c'est pour l'erreur... par contre, je sais pas si ton algorithme te donne le résultat espéré

Le 30/05/2013 à 11:35

Je viens de modifier le code:

Sub export()

Dim k, i, j, n As Integer

Application.DisplayAlerts = False

Sheets("TRANSFERT").Delete

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For k = 1 To Worksheets.Count - 1

n = ThisWorkbook.Worksheets(k).Cells(Rows.Count, 8).End(xlUp).Row + n

    For i = 1 To n

        For j = 1 To 3

        ThisWorkbook.Worksheets("TRANSFERT").Cells(i + n, j).Value = ThisWorkbook.Worksheets(k).Cells(i + 1, j).Value

        Next j

    Next i

Next k

End Sub

Plus d'erreur mais le résultat est bizarre.

J'ai actualisé le fichier à télécharger si tu veux jeter un coup d’œil.

Le 30/05/2013 à 11:49

essaye ce code

Sub transfert()

Dim a As Long

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For a = 1 To Sheets.Count
    If Sheets(a).Name <> "TRANSFERT" Then
        Sheets(a).Range("A1").CurrentRegion.Offset(1, 0) _
        .Resize(Sheets(a).Range("A1").CurrentRegion.Offset(1, 0).Rows.Count - 1, Sheets(a).Range("A1").CurrentRegion.Offset(1, 0).Columns.Count).Copy _
        Destination:=Sheets("Transfert").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
Next a

End Sub

PS : n'oublie pas de mettre les en-têtes dans toutes tes feuilles, il est manquant dans la feuil4.

Le 30/05/2013 à 11:53

J'ai réussi à faire tourner le code

Sub export()

Dim k, i, j, n As Integer

Application.DisplayAlerts = False

Sheets("TRANSFERT").Delete

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For k = 1 To Worksheets.Count - 1

n = ThisWorkbook.Worksheets(k).Cells(Rows.Count, 2).End(xlUp).Row + n

    For i = 1 To n

        For j = 1 To 2

        ThisWorkbook.Worksheets("TRANSFERT").Cells(i + n, j).Value = ThisWorkbook.Worksheets(k).Cells(i, j).Value

        Next j

    Next i

Next k

End Sub

Le tout marche bien.

Cependant j'aimerai y rajouter une subtilité dans le style,

si l'une des feuilles à la colonne B vide alors ne pas copier coller les valeurs de la feuille concerner.

Je suis en train de réfléchir sur une éventuelle fonction if.

Ton code marche nickel, il donne le même résultat que celui que j'ai posté en dernier.

Maintenant j'essaye d'y rajouter la condition tel qu'il ne faut pas copier les valeurs d'une feuille si celle-ci à la colonne B vide (sans oublier qu'il y aura titre à chaque colonnes qui eux seront des cellules non vide quelque soit le cas)

44exemple.xlsm (25.38 Ko)
Le 30/05/2013 à 12:02

le code prend en compte la colonne B vide

Sub transfert()
Application.ScreenUpdating = False
Dim a As Long

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For a = 1 To Sheets.Count
    If Sheets(a).Name <> "TRANSFERT" Then
        If Application.WorksheetFunction.CountA(Sheets(a).Columns(2)) > 1 Then
            Sheets(a).Range("A1").CurrentRegion.Offset(1, 0) _
            .Resize(Sheets(a).Range("A1").CurrentRegion.Offset(1, 0).Rows.Count - 1, Sheets(a).Range("A1").CurrentRegion.Offset(1, 0).Columns.Count).Copy _
            Destination:=Sheets("TRANSFERT").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        End If
    End If
Next a
Application.ScreenUpdating = True
End Sub
Le 30/05/2013 à 12:22

Le code marche à merveille!

Merci mille fois!

Je vais essayer de comprendre ceci pour le réutiliser sur la base.

Le 30/05/2013 à 12:27

un code amélioré qui t'évite de supprimer la feuille Transfert à chaque fois manuellement.

Sub transfert()

Dim a As Long
Application.ScreenUpdating = False

Application.DisplayAlerts = False
If shTest("TRANSFERT") = True Then Sheets("TRANSFERT").Delete
Application.DisplayAlerts = True

Sheets.Add.Move After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = "TRANSFERT"

For a = 1 To Sheets.Count
    If Sheets(a).Name <> "TRANSFERT" Then
        If Application.WorksheetFunction.CountA(Sheets(a).Columns(2)) > 1 Then
            Sheets(a).Range("A1").CurrentRegion.Offset(1, 0) _
            .Resize(Sheets(a).Range("A1").CurrentRegion.Offset(1, 0).Rows.Count - 1, Sheets(a).Range("A1").CurrentRegion.Columns.Count).Copy _
            Destination:=Sheets("TRANSFERT").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        End If
    End If
Next a
Application.ScreenUpdating = True
End Sub

Function shTest(aa As String) As Boolean
On Error Resume Next
shTest = Sheets(aa).Name <> ""
On Error GoTo 0
End Function
Le 30/05/2013 à 13:27

Un grand merci à toi.

Rechercher des sujets similaires à "report donnees feuilles seul feuille"