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.
 

Fichiers joints

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
 

vgendron

XLDnaute Barbatruc
Hello @gosselien
t'en vouloir? certainement pas. au contraire.. ton idée de faire un set Titre est d'une simplicité à laquelle je n'avais jamais pensé... je m'em...barquais systématiquement avec un if i=2 alors.. ...
 

Scorpio

XLDnaute Impliqué
Bonjour gosselien,
Bonjour à tous qui êtes en ligne,
Super, je vous en remercie beaucoup.
Bon travail, et merci à tous de votre aide sur le Forum.
A bientôt
Merci
 

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
 

zebanx

XLDnaute Accro
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++++
Bonjour Scorpio et à tous.

C'est l'occasion de tester la remarque de Gosselien
Quand on insère un code, à la place de ":" il y a parfois un smiley...et j'ai effacé le caractère "D".

++
zebanx


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

derligne = Sheets(1).Cells(Rows.Count, 1).End(3).Row
ta = Sheets(1).Range("A1:D" & 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
 

Staple1600

XLDnaute Barbatruc
Re

Donc on ignore le message#13* alors ?

Cela "dérange" personne de continuer à résoudre la question de Scorpio dans un fil initié par Icedarts

PS: Moi qui croyais que la coutume sur XLD était que l'Xldnaute créait sa propre discussion pour poser sa propre question.

*: Comme quoi ce chiffre 13 porte bien malheur, comme le chat noir et l'échelle.
Bien que je sois jamais passé sous une échelle en regardant un LolCat dans un WebBrowser sur Excel un vendredi 13 ;)
 

Scorpio

XLDnaute Impliqué
Re zebanx,
Je vous remercie infiniment, c'est parfais, ça marche très bien.
Je remercie encore grosselien, pour son code qui fonctionne à merveille.
Merci à tous, c'est très gentil.
Bon Week End à tous.
A++++
 

Staple1600

XLDnaute Barbatruc
Re

@Scorpio
Merci pour ta discourtoisie à mon endroit ;)
Apparemment tu n'as compris ce que je voulais te dire
Tu me diras tu n'avais compris non plus la suggestion de vgendron. ;)

Mais cela ne t’empêchait pas de rester courtois en répondant à mon premier message
(ou tout du moins en me saluant)

Pourtant dans d'autres fils, tu sais ne pas m'ignorer et me saluer ;)
Re Staple1600,
Effectivement, je n'ai pas encore utilisé les autres propositions,
Il me faux un peux de temps, merci
Et je profite pour remercier tous le monde de votre aide précieuse, car il est vrai que pour des personnes sans trop de bouteille pour ces codes VBA, le Forum est une chance
Merci à tous.
A bientôt
Promis, j'essaye les propositions ;)
 

Discussions similaires


Haut Bas