Macro pour tester nb de lignes puis copier

Bonjour le forum,

Toujours aussi nul en VBA, je sollicite votre aide à nouveau...

Je vous joins un extrait de fichier pour mieux comprendre :

https://www.excel-pratique.com/~files/doc/pEDlQDelais_de_traitement_projet_septembre_FORUM.xls

Dans le 1er onglet, je peux avoir 1, 2 ou 3 lignes par dossier. Je souhaite, à l'aide d'une macro, regrouper les infos des colonnes D, E, F, N, O, P et Q sur une seule ligne dans le 2ème onglet.

Mais je n'arrive pas à faire la boucle (je pense) pour tester le nombre de lignes et copier les infos dans l'autre onglet...

Bonjour,

çà me rappelle une certaine macro qui avait fait couler beaucoup d'encre ! !

(j'ai créer une feuille "bibi" pour tester.)

Sub essai1()
    Application.ScreenUpdating = False
        Range("d:f,n:q").Copy Destination:=Range("bibi!b1")

    Sheets("bibi").Activate '********** feuille à créer
        Range("b2").Select
    Do While ActiveCell <> ""
        If ActiveCell = ActiveCell.Offset(1, 0) And ActiveCell.Offset(0, 5) = "" And ActiveCell.Offset(0, 6) = "" Then
                    ActiveCell.Name = "top"
                    ActiveCell.Offset(0, 5).Name = "bip"
                Do While ActiveCell = ActiveCell.Offset(1, 0)
                    ActiveCell.Offset(1, 0).Select
                Loop
                    ActiveCell.Name = "top2"
                    ActiveCell.Offset(0, 6).Name = "bip2"

            Range("top:top2").Offset(0, 5).Select
                Selection.Sort Key1:=Range("bip"), Order1:=xlAscending, Header:=xlNo, _
                    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

            Range("top:top2").Offset(0, 6).Select
                Selection.Sort Key1:=Range("bip2"), Order1:=xlAscending, Header:=xlNo, _
                    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

                  Range(Range("top").Offset(1, 0), Range("top2")).EntireRow.Delete
                ActiveCell.Offset(-1, -6).Select
         End If
                    ActiveCell.Offset(1, 0).Select
    Loop
    ActiveWorkbook.Names("top").Delete
    ActiveWorkbook.Names("top2").Delete
    ActiveWorkbook.Names("bip").Delete
    ActiveWorkbook.Names("bip2").Delete
End Sub

Fichier :

https://www.excel-pratique.com/~files/doc/projet_septembre_FORUM.xls

amicalement

Claude.

re,

Je continue à apprendre en même temps !

La macro un peu + travaillée et qui traite les 4 colonnes de date :

Sub MemeLigne()
Dim Bip
Dim i As Byte
Dim j As Byte
Dim Nb
                    Application.ScreenUpdating = False
                Range("d:f,n:q").Copy Destination:=Range("bibi!b1")
            Sheets("bibi").Activate '********** feuille à créer
        Range("b2").Select
    Nb = Application.WorksheetFunction.CountA(Range("b:b")) - 1

    For i = 3 To 6
            For j = 1 To Nb
                If ActiveCell = ActiveCell.Offset(1, 0) And ActiveCell <> "" Then
                            ActiveCell.Name = "top"
                    Do While ActiveCell = ActiveCell.Offset(1, 0)
                        ActiveCell.Offset(1, 0).Select
                        j = j + 1
                    Loop
                            ActiveCell.Name = "top2"
                        Range("top:top2").Offset(0, i).Select
                        Selection.Sort Key1:=Range("top").Offset(0, i), Order1:=xlAscending, Header:=xlNo, _
                        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
                        [top2].Select
                 End If
                        ActiveCell.Offset(1, 0).Select
            Next j
                Range("b2").Select
    Next i
                Do While ActiveCell <> ""
                    If ActiveCell = ActiveCell.Offset(-1, 0) Then
                        ActiveCell.EntireRow.Delete
                        ActiveCell.Offset(-1, 0).Select
                    End If
                  ActiveCell.Offset(1, 0).Select
                Loop
        ActiveWorkbook.Names("top").Delete
        ActiveWorkbook.Names("top2").Delete
End Sub

amicalement

Claude.

Bonjour le forum,

Merci Claude pour le programme. Je teste et reviens vers toi pour te tenir au courant.

Merci encore,

Bonjour le forum,

Application.ScreenUpdating = False

Range("d:f,n:q").Copy Destination:=Range("bibi!b1")

Sheets("bibi").Activate '********** feuille à créer

Claude, j'ai essayé d'appliquer ton code et j'ai une erreur 400 quand je lance la macro dès le début ou une erreur 1004 quand je la lance en mode pas à pas.

Help !!! Je ne sais plus quoi faire.

Merci d'avance,

Fabrice,

Bonjour à tous,

Il faut que tu ajoute un onglet vierge nommé "bibi"

c'est pour tester, après, tu pourras changer ce nom.

amicalement

Claude.

Re-,

J'ai déjà tout essayé... J'ai renommé une feuille vierge, j'ai créé une feuille vierge "bibi"... J'avais déjà testé avant de te tenir informé. On dirait qu'il ne comprend pas la 1ère ligne de "Range("d:f,n:q")..................

Je ne vois pas...

Fabrice,

Bonjour,

Une autre proposition comme suit :

• Place ce code dans un module
• dessine un bouton sur ta feuille Délais de traitement
• clique droite sur le bouton puis choisis "associé à une macro"
• sélectionne la macro "regrouper" puis OK.
• Mets toi sur la feuille Délais de traitement puis clique sur le bouton pour exécuter la macro.

Sub Regrouper()
'Macro par Dan pour Fabrice69 - XL pratique 06/10/08
Dim Nom As Range, Val as range
Dim i As Integer, lig As Integer
Dim j As Byte
Application.ScreenUpdating = False
lig = Range("B65536").End(xlUp).Row
ActiveSheet.Copy after:=ActiveSheet
With ActiveSheet
    With .Range("B2", .Range("Q" & lig))
        .Copy
        .PasteSpecial Paste:=xlValues, Operation:=xlNone
    End With
    .Range("B2", .Range("Q" & lig)).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Each Nom In .Range("B2:B" & Range("B65536").End(xlUp).Row)
For i = 1 To .Range("B65536").End(xlUp).Row - 1
Set Val = Nom.Offset(i, 0)
If Val <> "" And Val = Nom Then
j = 14
Do While j <> 18
If Nom.Offset(i, j) <> "" Then
Nom.Offset(i, j).Copy Nom.Offset(i - 1, j)
End If
j = j + 1
Loop
Rows(Val.Row).Delete
i = i - 1
End If
Next i
Next Nom
End With
Columns("G:M").Delete
Columns("A:C").Delete
Range("A1").Select
End Sub

Amicalement

Dan

re,

est-ce-que çà marche sur mon fichier (en cliquant sur le bouton) ?

https://www.excel-pratique.com/~files/doc/projet_septembre_FORUM2.xls

Claude.

Re-,

Merci à vous 2... Je ne peux pas tester avant demain matin. Je vous tiens au courant.

Sincèrement,

Fabrice,

Bonjour le forum,

Claude, en cliquant sur le bouton macro, cela fonctionne. Par contre, quand je lance la macro pas à pas, excel me plante avec le message d'erreur "1004"...

Je ne comprends toujours pas ce qui se passe et je vais tester ce matin la solution de Dan.

Je ne peux pas me consacrer à 100% aux macros d'excel car j'ai d'autres tâches à faire mais je vais essayer d'y passer un peu plus de temps (pour être moins nul en VBA...)

Merci encore à vous 2.

Fabrice,

Bonjour au forum,

Fabrice, bon je vois, c'est parce-que tu ne démarre pas de la bonne feuille.

on pourrait ajouter cette ligne en début de code :

Sub MemeLigne()

Dim Bip

Dim i As Byte

Dim j As Byte

Dim Nb

Sheets("Délais de traitement").Activate

Claude.

Bonjour le forum,

Claude, Dan, pour être sur de ne pas me tromper, je suis reparti avec un fichier propre et sans macro qui possède 3 onglets : "Délais de traitement", "Lignes", "bibi". J'ai copié respectivement vos codes dans la feuille "Module1".

Quand j'exécute la macro de Claude, j'ai : "erreur d'exécution 6... Dépassement de capacité" visiblement quand le programme arrive à la ligne "For j = 1 To Nb"...

Quand j'exécute la macro de Dan, un onglet "Délais de traitement(2)" se créé et j'ai : "erreur d'exécution 13... Incompatibilité de type" visiblement quand le programme arrive à la ligne "If Nom.Offset(i,j) <> "" Then"...

Désolé de vous ennuyer mais cela ne fonctionne pas.

Merci à vous 2 par avance...

Fabrice,

re,

il fait combien de lignes ton fichier ?

Ne désespère pas, on vas trouver !

Claude.

Bonjour le forum,

Mon fichier fait 910 lignes mais c'est aléatoire puisque je récupère un nouveau fichier tous les jours. En règle générale, le nombre de lignes sera entre 500 et 1500...

Je ne désespère pas mais je me sens un peu "largué" quand je vois votre niveau en VBA... Mais je ne désespère pas...

Merci d'avance,

Fabrice,

re,

La macro focntionne parfaitement dans le fichier que tu as posté sur le forum.

Essaye aussi en remplaçant l'instruction

If Nom.Offset(i,j) <> "" Then

par

If Not IsEmpty(Nom.Offset(i, j)) Then

Si tu as toujours un pb, donne nous le fichier qui pose un souci chez toi ce sera plus facile.

A te relire

Dan

Bonjour à tous,

Salut Dan et Fabrice,

Dans ma version :

remplace :

Dim j As Byte

par

Dim j As Integer

le traitement est long pour 1520 lignes (4 minutes)

amicalement

Claude.

Re-,

Claude, Dan... Bonne nouvelle... Je n'ai plus de message d'erreur dans les 2 macros. Par contre, je joins le fichier d'origine (tronqué d'environ 900 lignes et avec les colonnes K et L à blanc car données confidentielles...).

https://www.excel-pratique.com/~files/doc/2itglDelais_de_traitement_projet_septembre_FORUM.xls

J'ai testé les 2 macros et je n'ai pas réussi à modifier le code pour l'adapter au fichier d'origine (il me manque toujours une colonne) mais comme il y a des commandes VBA que je ne comprends pas...

Merci par avance de votre précieuse aide...

Fabrice,

re,

tu avais un décalage d'une colonne par rapport à ce fichier

https://www.excel-pratique.com/~files/doc/projet_septembre_FORUM3.xls

édit: sans feuille bibi

tu nous diras les temps de traitement, S-T-P

Claude.

Re,

Hum normal que la macro ne fonctionne pas correctement, ton fichier n'est pas le même.

Ton fichier en retour avec la macro adaptée.

FICHIER

Amicalement

Dan