XL 2016 Extraire données d'une colonne en fonction de la ligne du dessous

Icedarts

XLDnaute Occasionnel
Bonjour à tous,

J'ai un fichier excel contenant des lignes qui commencent toutes par Nom suivi du nom d'une personne.
C'est la ligne du dessus qui m'interesse.
Je ne souhaite conserver que cette ligne pour pouvoir faire des stats en fonction des lieux.

Si toutes les lignes commencaient par Lieux ça serait simple je pourrais faire un tri mais nom j'ai directement le nom de la ville avec le temps.

Donc il faudrait un code qui cherche les lignes commençant par Nom et qui conserve que la ligne au dessus en la mettant dans une autre feuille ou dans une autre colonne peu importe.

Ça aurait pu être simple aussi si les ecart entre les lignes étaient identiques mais ce n'est pas le cas non plus :/

Un exemple en pièce jointe.

Merci d'avance pour votre aide.
 

Pièces jointes

  • Classeur2.xlsx
    8.3 KB · Affichages: 48

Scorpio

XLDnaute Impliqué
Bonjour Icedarts, et vgendron.
J'ai remarqué sur le site votre communication, et comme je suis pas un caïd en code, je suis intéressé par votre classeur.
Mai si je peux me permettre, j'aimerais juste apporté une correction.
En fait, lorsque je fais l'extraction des lignes se situant au dessus de la ligne contenant le "Nom", j'aimerais que le code prennent en considération plusieurs colonne, ex: colonne A,B,C,D, etc
Et aussi que le code ne supprime pas le titre dans la colonne "A", en feuille 2.
Merci à vous et à ++++
 

gosselien

XLDnaute Barbatruc
Bonjour,

en reprenant le code de vgendron que je salue et qui ne m'en voudra pas j'espère , voilà ce qu'on peut obtenir :)

P.
VB:
Sub lieuxtemps()
Dim tablo() As Variant
Dim Titre
Set Titre = Feuil1.Range("A1:D1")
Sheets("Feuil2").Cells.Clear
tablo = Sheets("Feuil1").UsedRange.Offset(1, 0).Value
For i = LBound(tablo, 1) To UBound(tablo, 1)
    'Recherche ligne avec "Nom"
    If tablo(i, 1) Like "Nom*" Then
    'Trouve la ligne au dessus de la ligne "Nom" et extraire dans feuille 2
        Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = tablo(i - 1, 1)
        Sheets("Feuil2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = tablo(i - 1, 2)
        Sheets("Feuil2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = tablo(i - 1, 3)
        Sheets("Feuil2").Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = tablo(i - 1, 4)
    End If
Next i
Titre.Copy Sheets("Feuil2").[A1]
End Sub
 

zebanx

XLDnaute Accro
Bonsoir Scorpio, Vgendron, Gosselien

En plus long que la solution présentée par Gosselien mais en se focalisant sur une donnée non vide en colonne B.
Autre approche..

++ et bonne soirée à tous
zebanx

-----
Sub copyd()
Dim ta(), tb()

derligne = Sheets(1).Cells(Rows.Count, 1).End(3).Row
ta = Sheets(1).Range("A1:" & derligne).Value
ReDim tb(1 To UBound(ta, 1), 1 To 4)
n = 1

For i = LBound(ta, 1) To UBound(ta, 1)
If ta(i, 2) <> "" Then
For j = 1 To 4
tb(n, j) = ta(i, j)
Next j
n = n + 1
End If
Next i

Sheets(2).Cells.ClearContents
Sheets(2).Cells(1, 1).Resize(UBound(tb, 1), 4) = tb

End Sub
 

gosselien

XLDnaute Barbatruc
Bonsoir Scorpio, Vgendron, Gosselien

En plus long que la solution présentée par Gosselien mais en se focalisant sur une donnée non vide en colonne B.
Autre approche..

++ et bonne soirée à tous
zebanx

-----
Sub copyd()
Dim ta(), tb()

derligne = Sheets(1).Cells(Rows.Count, 1).End(3).Row
ta = Sheets(1).Range("A1:" & derligne).Value
ReDim tb(1 To UBound(ta, 1), 1 To 4)
n = 1

For i = LBound(ta, 1) To UBound(ta, 1)
If ta(i, 2) <> "" Then
For j = 1 To 4
tb(n, j) = ta(i, j)
Next j
n = n + 1
End If
Next i
Sheets(2).Cells.ClearContents
Sheets(2).Cells(1, 1).Resize(UBound(tb, 1), 4) = tb
End Sub

Hello @zebanx ,

c'eut été mieux de mettre ça en passant par la petite icône "insérer/code/vb" :) :)

VB:
Sub copyd()
Dim ta(), tb()
derligne = Sheets(1).Cells(Rows.Count, 1).End(3).Row
ta = Sheets(1).Range("A1:" & derligne).Value
ReDim tb(1 To UBound(ta, 1), 1 To 4)
n = 1
For i = LBound(ta, 1) To UBound(ta, 1)
If ta(i, 2) <> "" Then
For j = 1 To 4
tb(n, j) = ta(i, j)
Next j
n = n + 1
End If
Next i
Sheets(2).Cells.ClearContents
Sheets(2).Cells(1, 1).Resize(UBound(tb, 1), 4) = tb
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum

[de passage]
vgendron fut pourtant explicite
bonjour @Scorpio
je te suggère de créer un nouveau post avec ton fichier exemple
Ca permettra de te donner une réponse adéquate.
Et ensuite, c'est la drame, tout le monde s'est engouffré dans le tunnel ;) et personne n'a vu la lumière

PS: @Scorpio
vgendron voulait dire : créer une nouvelle discussion
Ta discussion pour y poser ta question.
[/de passage]
 

Scorpio

XLDnaute Impliqué
Re zebanx,
Après voir fais le test avec ce code, il m'indique une erreur que je signal dans la ligne en gras.
A++++


Sub copyd()
Dim ta(), tb()

derligne = Sheets(1).Cells(Rows.Count, 1).End(3).Row
ta = Sheets(1).Range("A1:" & derligne).Value 'ERREUR
ReDim tb(1 To UBound(ta, 1), 1 To 4)
n = 1

For i = LBound(ta, 1) To UBound(ta, 1)
If ta(i, 2) <> "" Then
For j = 1 To 4
tb(n, j) = ta(i, j)
Next j
n = n + 1
End If
Next i

Sheets(2).Cells.ClearContents
Sheets(2).Cells(1, 1).Resize(UBound(tb, 1), 4) = tb

End Sub
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 848
dernier inscrit
Djigbenou