Glisser-déposer multiples

Bonjour,

J'ai un petit problème : j'ai un fichier excel (2003) qui comporte plusieurs données texte (des titres) dans une première colonne et des valeurs par mois dans les suivantes.

Comme les titres sont présents plusieurs fois je souhaiterais glisser leurs valeurs dans la première ligne du titre pour pouvoir supprimer les lignes en trop, de façon à avoir sur une seule ligne le titre et toutes ses valeurs, sans répétition.

Comme c'est assez dur pour moi de l'expliquer je vous joins un fichier d'exemple.

Mon principal problème c'est que je ne trouve pas comment réaliser de multiples glisser-déposer. Sachant que mon fichier comporte 13000 lignes je ne peux pas tout glisser à la main ligne par ligne...

Pouvez-vous m'aider?

N'hésitez pas à me demander des précisions si je ne suis pas claire, ce qui ne m'étonnerai pas ^^

Merci d'avance

Bonjour et bienvenue

Ton fichier en retour (active les macros et clique sur le bouton REGROUPER)

Amicalement

Nad

Bonjour,

Je vous remercie ! Effectivement le fichier fonctionne bien.

Mais malheureusement, j'ai testé la macro sur mon fichier d'origine (celui de 13000 lignes) et j'ai une erreur :

"Erreur d'exécution '6' : Dépassement de capacité"

De quoi s'agit-il? Que faire?

Merci pour votre aide !

Castor32

Re

Essaye en remplaçant (au début du code) n As Integer par n As Long

Nad

Re,

J'ai changé ce qui a donné ceci :

Option Explicit
Option Base 1
Sub Trier()
' Macro enregistrée le 28/05/2006 par CBernardT
Dim Lig As Long, i As Long, j As Long, k As Byte, n As Long, X As Byte

Application.ScreenUpdating = False
Lig = Range("B65536").End(xlUp).Row

For i = 5 To Lig

   For n = 5 To Lig
   If Cells(n, 2) = Cells(i, 2) Then
   X = X + 1
   End If
   Next n

If X > 1 Then ' S'il y en a plus d'une Recherche des occurences du projet

   For j = i + 1 To Lig
      If Cells(j, 2) = Cells(i, 2) Then

         For k = 3 To 10
         If Cells(j, k) <> "" Then
         Cells(i, k) = Cells(j, k)
         Range(Cells(j + 1, 2), Cells(Lig + 1, 10)).Copy Cells(j, 2) ' Remontée du tableau
         End If
         Next k
      End If
   Next j
End If
X = 0
Next i
Application.ScreenUpdating = True
End Sub

Mais cela ne fonctionne toujours pas. Je suis une novice, je tatonne mais là... Les macros c'est du chinois !

Re-bonjour,

Le fichier n'étant pas organisé exactement comme la version que j'avais mise en exemple la super macro de Nad ne fonctionnait plus, il m'en a ait une autre que je vous met ici :

Option Base 1
Sub Trier()
' Macro enregistrée le 28/05/2006 par CBernardT
Dim Lig As Long, i As Long, j As Long, k As Byte, n As Long, X As Byte

Application.ScreenUpdating = False
Lig = Range("A65536").End(xlUp).Row

For i = 3 To Lig
   For n = 3 To Lig
   If Cells(n, 1) = Cells(i, 1) Then
   X = X + 1
   End If
   Next n
If X > 1 Then

   For j = i + 1 To Lig
      If Cells(j, 1) = Cells(i, 1) Then

         For k = 2 To 25
         If Cells(j, k) <> "" Then
         Cells(i, k) = Cells(j, k)
         Range(Cells(j + 1, 1), Cells(Lig + 1, 25)).Copy Cells(j, 1)
         End If
         Next k
      End If
   Next j
End If
X = 0
Next i
Application.ScreenUpdating = True
End Sub

Elle fonctionne bien sauf lorsque deux informations sont sur la même ligne, une des deux saute et n'est plus copiée.

Quelqu'un voit-il une solution?

Je vous joint le fichier, cette fois-ci bien conforme à mon fichier original !

Merci à Nad !

Re

Peux-tu tester cette macro :

Sub Regroupe()
'ATTENTION ! Les données de la colonne A doivent être regroupées par nom
Application.ScreenUpdating = False
Dim Lig As Long, i As Long, j As Long, k As Long

Lig = Range("A65536").End(xlUp).Row

For i = Lig To 4 Step -1
For j = 2 To 25

If Cells(i, 1) = Cells(i - 1, 1) Then
If Cells(i, j) <> "" Then
Cells(i, j).Cut Destination:=Cells(i - 1, j)
End If
End If

Next j
Next i

Lig = Range("A65536").End(xlUp).Row
For k = Lig To 3 Step -1
If Application.WorksheetFunction.CountA(Rows(k)) = 1 Then Rows(k).Delete
Next k

End Sub

Amicalement

Nad

Super ! Ca marche ! Par contre il ne supprime plus les lignes vides...

Re

Ben si, il les supprime.

Regarde avec ton dernier fichier :

Nad

Oui ! Ca marche !

(c'était de ma faute)

Je te remercie infiniment ! Quel gain de temps !

C'est super !