VBA : Retour à la ligne avec conditionnalité

[captainr38]

Bonjour à tous,

Je souhaite réorganiser un ensemble de données qui se trouve sous forme d'une seule colonne(cf. fichiers "Test" joint/"Onglet DATA") en tableau (cf. fichiers "Test" joint/Onglet "Résultat souhaité")

J'utilise pour cela la fonction transposition suivante:

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Mon problème est le suivant : Je dois revenir à la ligne systématiquement lorsqu'un certain Mot apparait. Dans le fichier Test Joint, ce mot est "TOTO".
Ce mot apparait de façon aléatoire.


Merci d'avance pour votre aide.

Matthieu

 

[Sofhy]

Re : VBA : Retour à la ligne avec conditionnalité

Bonjour captainr38,

Je ne sais pas si mon Excel qui a des problèmes, mais je n'arrive pas à ouvrir ton fichier...

A+,
Sophie

 

[captainr38]

Re : VBA : Retour à la ligne avec conditionnalité

OK Merci pour l'info Sophie
Je joins un nouveau fichier Test (1).

++

 

[Cousinhub]

Re : VBA : Retour à la ligne avec conditionnalité

Bonsoir,

En préambule, changer l'extension ne suffit pas, il faut "Enregistrer sous 1997/2003" lorsque tu es en 2007

Ci-dessous, 2 codes différents, qui te réalisent ce que tu désires...

Sub toto()
Dim Cel As Range
Dim C As Range, D As Range
Application.ScreenUpdating = False
With Columns(2)
    Set C = .Find("TOTO")
    If Not C Is Nothing Then
        PremAdress = C.Address
        Do
            Set D = .FindNext(C)
            If Not D Is Nothing And D.Row > C.Row Then
                C.Resize(D.Row - C.Row, 1).Copy
                Sheets("Résultat souhaité").Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            Else
                C.Resize([B65000].End(xlUp).Row + 1 - C.Row, 1).Copy
                Sheets("Résultat souhaité").Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False
                Exit Sub
            End If
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address <> FirstAddress
    End If
End With
End Sub


Sub toto2()
Dim Cel As Range
Dim LeMot As Object
Dim DerLig As Long, I As Long
Dim F1 As Worksheet, F2 As Worksheet
Dim Temp
Application.ScreenUpdating = False
Set F1 = Sheets("DATA")
Set F2 = Sheets("Résultat souhaité")
Set LeMot = CreateObject("Scripting.Dictionary")
DerLig = F1.[B65000].End(xlUp).Row
For Each Cel In F1.Range("B2:B" & DerLig)
    If Cel.Value = "TOTO" Then LeMot(Cel.Row) = Cel.Row
Next Cel
Temp = LeMot.Items
For I = LBound(Temp) To UBound(Temp)
    If I < UBound(Temp) Then
        F1.Range(F1.Cells(Temp(I), 2), F1.Cells(Temp(I + 1) - 1, 2)).Copy
        F2.Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Else
        F1.Range(F1.Cells(Temp(I), 2), F1.Cells(DerLig, 2)).Copy
        F2.Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    End If
Next I
Application.CutCopyMode = False
End Sub

Bonne soirée

 

[captainr38]

Re : VBA : Retour à la ligne avec conditionnalité

Merci bhbh

Impressioné par la vitesse d'exécution!
ça marche parfaitement.
J'ai néanmoins une autre petite question.
J'ai exactement le même problème cependant cette fois-ci je souhaite utiliser qu'une partie du Texte de la case pour revenir à la ligne (Cf fichier Test(2)).
J'imagine qu'on doit pouvoir le spécifier dans la fonction ". Find()"
Merci de ta réponse

A+
Matthieu

 

[Cousinhub]

Re : VBA : Retour à la ligne avec conditionnalité

Re-,

dans le 1er code, modifie ainsi :

Set C = .Find("TOTO", LookAt:=xlPart)

et dans le 2ème :

If Cel.Value Like "*TOTO*" Then LeMot(Cel.Row) = Cel.Row

Bonne soirée

 

[gilbert_RGI]

Re : VBA : Retour à la ligne avec conditionnalité

Bonjour

BhBh plus rapide

voilà ce que j'avais fait

Sub test()
    Dim Str_Plage As String
    Dim Cel As Range
    Dim Feuil As Worksheet
    Dim Str_critère As String
    Str_Plage = "B1:B112"
    Str_critère = "toto"
    If Str_critère = "" Then GoTo fin
    Columns("E:E").Select
    Selection.ClearContents
    For Each Feuil In Sheets
        For Each Cel In Feuil.Range(Str_Plage)
            If UCase(Cel) Like "*" & UCase(Str_critère) & "*" Then
                Feuil.Activate
                Cel.Activate
                Z = Cel.Row
                Cells(Range("e65536").End(xlUp).Row + 1, 5).Value = Z
            End If
        Next Cel
    Next Feuil
    Cells(Range("e65536").End(xlUp).Row + 1, 5).Value = Range("b65536").End(xlUp).Row + 1
    On Error GoTo fin
    For y = 2 To Range("e65536").End(xlUp).Row
        Range("B" & Cells(y, 5) & ":B" & Cells(y + 1, 5) - 1).Select
        Selection.Copy
        Cells(Range("f65536").End(xlUp).Row + 1, 6).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                               False, Transpose:=True
    Next
fin:
    Columns("E:E").Select
    Selection.ClearContents
End Sub

 

[captainr38]

Re : VBA : Retour à la ligne avec conditionnalité

Merci Bhbh tout est ok!
Je retiens vraiment ce FORUM car je suis impressionné par la réactivité des internautes et la pertinence des réponses apportées.
Merci également pour ta réponse Gilbert, Bhbh avait en effet dégainé très vite.
A bientôt