[Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Kirko · 14 Mai 2012

Bonjour à tous,

j'ai un fichier Excel qui s'organise de cette facon (Voir PJ):
........a............... b ................c ................d .................e
1 VER:Savoir PRO:Je ADV:Bien ART:Le NOM: Matin
2 PRO:Il ART:LA VER:etre INT: Ah ADJ: Beau
3 ETC......
4
5

Ce que je voudrais faire, ca serait de mettre sous une colonne tous les VER, sous une autre tous les ART, ainsi de suite ... Pour cela, ce que je pensais faire, c'etait d'entrer une formule, en lui demandant de rechercher pou chaque ligne "VER" et de copier alors la cellule dans la colonne dédiée au verbes ... mais je n'arrive pas à le faire.

C'est pourquoi je viens à vous.
En vous remerciant d'avance.

WUTED · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Bonjour Kirko,

Je suis désolé de pas pouvoir plus t'aider dans l'immédiat mais j'ai fait ce petit code en vba :

VB:

Sub tri()
    'Déclaration des différents compteur de lignes
    Dim lignPRO As Integer
    Dim lignDET As Integer
    Dim lignVER As Integer
    Dim lignADV As Integer
    For i = 1 To Sheets("Feuil1").Range("A65536").End(xlUp).Row
        For j = 0 To Sheets("Feuil1").Range("IV" & i).End(xlUp).Row
            If Sheets("Feuil1").Range("A" & i).Offset(0, j).Value Like "PRO*" Then
                Sheets("Feuil2").Range("A1").Offset(lignPRO, 0).Value = Sheets("Feuil1").Range("A" & i).Offset(0, j).Value
                lignPRO = lignPRO + 1
            End If
            If Sheets("Feuil1").Range("A" & i).Offset(0, j).Value Like "DET*" Then
                Sheets("Feuil2").Range("B1").Offset(lignDET, 0).Value = Sheets("Feuil1").Range("A" & i).Offset(0, j).Value
                lignDET = lignDET + 1
            End If
            If Sheets("Feuil1").Range("A" & i).Offset(0, j).Value Like "VER*" Then
                Sheets("Feuil2").Range("C1").Offset(lignVER, 0).Value = Sheets("Feuil1").Range("A" & i).Offset(0, j).Value
                lignVER = lignVER + 1
            End If
            If Sheets("Feuil1").Range("A" & i).Offset(0, j).Value Like "ADV*" Then
                Sheets("Feuil2").Range("D1").Offset(lignADV, 0).Value = Sheets("Feuil1").Range("A" & i).Offset(0, j).Value
                lignADV = lignADV + 1
            End If
        Next
    Next
End Sub

Il gère seulement les cas PRO,DET,VER,ADV : il recopie les valeurs des cellules dans la deuxième feuille, en les classant par colonne. Cependant tu peux facilement finir le code, il suffit de rajouter à chaque fois une variable ligne (lignPRO,lignDET..) et de copier/coller le if suivant (et le mettre à la suite des autres) en remplaçant TEST par le début de ton expression, comme j'ai fait avec PRO,DET,etc.. :

VB:

 If Sheets("Feuil1").Range("A" & i).Offset(0, j).Value Like "TEST*" Then
                'Décaler la colonne de 1 à chaque fois, ou même changer les colonnes selon tes envies
                Sheets("Feuil2").Range("C1").Offset(lignTEST, 0).Value = Sheets("Feuil1").Range("A" & i).Offset(0, j).Value
                lignTEST = lignTEST + 1
 End If

Bonne journée,
WUTED

job75 · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Bonjour Kirko, bienvenue sur XLD, salut WUTED,

Cette macro dans le fichier joint :

Code:

Sub Analyse()
Dim tablo, ub%, d As Object, i&, j%, p%, restit$(), col%
tablo = Feuil1.UsedRange 'Feuil1 => CodeName à adapter
ub = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
With Feuil2 'CodeName de la feuille de restitution, à adapter
  '---titres des colonnes, sans doublon---
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      tablo(i, j) = Application.Trim(tablo(i, j)) 'SUPPRESPACE
      tablo(i, j) = Replace(tablo(i, j), "::", ":") 'pour PUN...
      p = InStrRev(tablo(i, j), ":")
      If p Then d(Left(tablo(i, j), p)) = Left(tablo(i, j), p)
    Next
  Next
  .Cells.ClearContents 'RAZ
  .[A1].Resize(, d.Count) = d.Items
  .[1:1].Sort .[1:1], Orientation:=xlLeftToRight 'tri
  '---analyse ligne par ligne---
  ReDim restit(1 To UBound(tablo), 1 To d.Count)
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      p = InStrRev(tablo(i, j), ":")
      If p Then
        col = Application.Match(Left(tablo(i, j), p), .[1:1], 0)
        restit(i, col) = Mid(tablo(i, j), p + 1)
      End If
    Next
  Next
  .[A2].Resize(UBound(tablo), d.Count) = restit
  .Activate
End With
End Sub

L'analyse se fait ligne par ligne, mais on pourrait supprimer les cellules vides si nécessaire.

A+

job75 · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Re,

Si l'on veut supprimer les cellules vide, mettre ce code en fin de macro :

Code:

On Error Resume Next 'si aucune cellule vide
.UsedRange.SpecialCells(xlCellTypeBlanks).Delete xlUp 'facultatif

Bien entendu on ne sait plus alors à quelle ligne un texte appartenait.

Fichier joint.

A+

job75 · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Re,

J'avais mal regardé le tableau !

Sur une même ligne, il peut y avoir plusieurs textes pour un même titre...

Alors je pense qu'il vaut mieux utiliser cette version :

Code:

Sub Analyse()
Dim tablo, ub%, d As Object, i&, j%, p%, Nb&(), col%, restit$()
tablo = Feuil1.UsedRange 'Feuil1 => CodeName à adapter
ub = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
With Feuil2 'CodeName de la feuille de restitution, à adapter
  '---titres des colonnes, sans doublon---
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      tablo(i, j) = Application.Trim(tablo(i, j)) 'SUPPRESPACE
      tablo(i, j) = Replace(tablo(i, j), "::", ":") 'pour PUN...
      p = InStrRev(tablo(i, j), ":")
      If p Then d(Left(tablo(i, j), p)) = Left(tablo(i, j), p)
    Next
  Next
  .Cells.ClearContents 'RAZ
  .[A1].Resize(, d.Count) = d.Items
  .[1:1].Sort .[1:1], Orientation:=xlLeftToRight 'tri
  '---analyse ligne par ligne---
  ReDim Nb(1 To d.Count)
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      p = InStrRev(tablo(i, j), ":")
      If p Then
        col = Application.Match(Left(tablo(i, j), p), .[1:1], 0)
        Nb(col) = Nb(col) + 1
        ReDim Preserve restit(1 To d.Count, 1 To Application.Max(Nb))
        restit(col, Nb(col)) = Mid(tablo(i, j), p + 1)
      End If
    Next
  Next
  .[A2].Resize(Application.Max(Nb), d.Count) = Application.Transpose(restit)
  .Activate
End With
End Sub

Une contrainte : Application.Transpose n'accepte pas plus de 65536 lignes.

Fichier joint.

A+

job75 · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Re,

J'ai mis un Like au post #1, car pour un 1er post de Kirko c'est remarquable 🙂

A+

job75 · 14 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Re, pour terminer,

Si la restitution a plus de 65536 lignes, il faut transposer à la fin item par item :

Code:

'---transposition et restitution---
ReDim Tr(1 To Application.Max(Nb), 1 To d.Count)
ub = UBound(Tr, 2)
For i = 1 To UBound(Tr)
  For j = 1 To ub
    Tr(i, j) = restit(j, i)
  Next
Next
.[A2].Resize(UBound(Tr), ub) = Tr

Fichier (2).

Edit : j'ai testé les 2 versions sur un tableau de 36600 lignes avec Win XP/Excel 2003.

Curieusement cette version (2) est un peu plus rapide : 35,6 s au lieu de 37,6 s.

A+

Kirko · 15 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Merci infiniment Wuted et Job 75, je sais pas comment vous avez fabriqué ça, mais vous êtes très franchement impressionnant !

Job75, le post que j'i quoté, c'est celui qui correspond le mieux à ce que je recherchais (qui correspond à 100% en fait) car par rapport proposition suivantes, celle-ci garde les caractéristiques de chaque ligne et ne mélange pas toutes les données.(il faut prendre les données de chaque ligne comme les caractéristiques d'une personne, donc dissociable.)

J'aurais bien aimé demandé des explication sur la façon de faire, mais j'imagine que ça doit être du codage particulierment compliqué et du coup je me contente de te dire un très grand merci. J'imagine qu'avec les formules classiques, je n'aurais jamais pu avoir un tel résultat ....

job75 à dit:

Bonjour Kirko, bienvenue sur XLD, salut WUTED,

Cette macro dans le fichier joint :

Code:

Sub Analyse()
Dim tablo, ub%, d As Object, i&, j%, p%, restit$(), col%
tablo = Feuil1.UsedRange 'Feuil1 => CodeName à adapter
ub = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
With Feuil2 'CodeName de la feuille de restitution, à adapter
  '---titres des colonnes, sans doublon---
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      tablo(i, j) = Application.Trim(tablo(i, j)) 'SUPPRESPACE
      tablo(i, j) = Replace(tablo(i, j), "::", ":") 'pour PUN...
      p = InStrRev(tablo(i, j), ":")
      If p Then d(Left(tablo(i, j), p)) = Left(tablo(i, j), p)
    Next
  Next
  .Cells.ClearContents 'RAZ
  .[A1].Resize(, d.Count) = d.Items
  .[1:1].Sort .[1:1], Orientation:=xlLeftToRight 'tri
  '---analyse ligne par ligne---
  ReDim restit(1 To UBound(tablo), 1 To d.Count)
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      p = InStrRev(tablo(i, j), ":")
      If p Then
        col = Application.Match(Left(tablo(i, j), p), .[1:1], 0)
        restit(i, col) = Mid(tablo(i, j), p + 1)
      End If
    Next
  Next
  .[A2].Resize(UBound(tablo), d.Count) = restit
  .Activate
End With
End Sub

L'analyse se fait ligne par ligne, mais on pourrait supprimer les cellules vides si nécessaire.

A+

job75 · 15 Mai 2012

Re : [Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Bonjour Kirko,

Je m'étais douté que vous souhaiteriez pouvoir repérer les caractéristiques de chaque ligne.

Alors voici la 1ère version améliorée :

Code:

Sub Analyse()
Dim tablo, ub%, d As Object, i&, j%, p%, restit$(), col%
tablo = Feuil1.UsedRange 'Feuil1 => CodeName à adapter
ub = UBound(tablo, 2)
Set d = CreateObject("Scripting.Dictionary")
With Feuil2 'CodeName de la feuille de restitution, à adapter
  '---initialisation---
  .Cells.Delete
  .[1:1].Font.Bold = True 'gras
  .[1:1].Font.ColorIndex = 5 'bleu
  '---titres des colonnes, sans doublon---
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      tablo(i, j) = Trim(tablo(i, j)) 'des titres sont précédés d'espaces...
      tablo(i, j) = Replace(tablo(i, j), "::", ":") 'pour PUN...
      p = InStrRev(tablo(i, j), ":")
      If p Then d(Left(tablo(i, j), p)) = Left(tablo(i, j), p)
    Next
  Next
  .[A1].Resize(, d.Count) = d.Items
  .[1:1].Sort .[A1], Orientation:=xlLeftToRight 'tri
  '---analyse ligne par ligne---
  ReDim restit(1 To UBound(tablo), 1 To d.Count)
  For i = 1 To UBound(tablo)
    For j = 1 To ub
      p = InStrRev(tablo(i, j), ":")
      If p Then
        col = Application.Match(Left(tablo(i, j), p), .[1:1], 0)
        restit(i, col) = restit(i, col) & IIf(restit(i, col) = "", "", vbLf) & Mid(tablo(i, j), p + 1)
      End If
    Next
  Next
  '---restitution---
  .[A2].Resize(UBound(tablo), d.Count) = restit
  .UsedRange.Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
End Sub

Quand sur une même ligne il y a plusieurs textes pour un même titre, ils sont concaténés avec un saut de ligne (vbLf) comme séparateur.

Fichier (2).

A+

[Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

Kirko

XLDnaute Nouveau

Pièces jointes

WUTED

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Kirko

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

[Excel] Comment trouver le contenu d'une cellule dans une ligne, puis la copier

XLDnaute Nouveau

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency