Microsoft 365 Tri/Selection de données

decga

XLDnaute Nouveau
Bonjour,

J'ai une liste de données du type dans un fichier :

11256_1
25663_2
56666
66226_2
52626
26526_1

Et j'aimerais faire une copie uniquement des données se terminant pas "_2 "
Et dans un second temps, une fois que les données sont copié j'aimerais enlever le "_2"

Est ce que cela est possible?

Merci d'avance
 

Staple1600

XLDnaute Barbatruc
Re

Je te laisse tester ce petit exemple (sur une feuille vierge)
VB:
Sub Test()
fo = Array(Array(1, 1), Array(2, 9))
'============> ne sert qu'à créer les données pour le test
a = Array("TEXT", "11256_1", "25663_2", "56666", "66226_2", "52626", "26526_1")
Range("A1:A7") = Application.Transpose(a)
'============> fin création données

'copie avec filtre avancé
Range("D2").FormulaR1C1 = "=RIGHT(RC[-3])=""2"""
Range("A1:A7").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("D1:D2"), CopyToRange:=Range("F1"), Unique:=False

'données/convertir
Range("F2:F5").TextToColumns Destination:=Range("F2"), DataType:=xlDelimited, Other:=True, OtherChar:="_", FieldInfo:=fo
End Sub
J'ai mis une macro pour expliquer le mode opératoire mais cela se fait facilement à la souris (sans macro)
1) Filtre avancé avec recopie et un critère par formule (voir la formule en D2)
2) Utilisation de Données/Convertir pour supprimer le 2
 

xUpsilon

XLDnaute Accro
Bonjour


VB:
n = 1
For i = 1 to Sheets(1).Range("A1").End(xlDown).Row
    If Right(Range("A" & i),2) = "_2" then
        Sheets(2).Range("A" & n) = Right(Sheets(1).Range("A" & i);Len(Sheets(1).Range("A" & i) -2)
        n = n +1
    End if
Next i
Quelque chose comme ça conviendrait il ?
Sans fichier exemple je t'avoue que c'est compliqué d'adapter proprement.

Bonne continuation
 

decga

XLDnaute Nouveau
Bonjour


VB:
n = 1
For i = 1 to Sheets(1).Range("A1").End(xlDown).Row
    If Right(Range("A" & i),2) = "_2" then
        Sheets(2).Range("A" & n) = Right(Sheets(1).Range("A" & i);Len(Sheets(1).Range("A" & i) -2)
        n = n +1
    End if
Next i
Quelque chose comme ça conviendrait il ?
Sans fichier exemple je t'avoue que c'est compliqué d'adapter proprement.

Bonne continuation

Merci pour le code mais entre temps j'ai réussi autrement
VB:
For i = 2 To 100

    If Right(Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i), 2) = "_2" Then
        
        Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Range("A" & i).Value = Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i).Value
    End If
Next i

Maintenant le problème est que je n'arrive pas supprimer les lignes vides entre les données copiées (exemple en dessous)
1572343945891.png


Mon code :

Code:
Sub Traction_V2()

Dim i As Integer

'U0A vers V2

For i = 2 To 100

    If Right(Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i), 2) = "_2" Then
        
        Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Range("A" & i).Value = Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i).Value

        Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Range("A" & i).Font.Color = RGB(200, 0, 200)
        
    End If
    

    If Range("A" & i) = "" Then 'Ca ne fonctionne à partir de cette ligne
        
        Range("A" & i).EntireRow.Delete
                
    End If
    
Next i

End Sub
 

xUpsilon

XLDnaute Accro
VB:
Sub Traction_V2()

Dim i,n As Integer
n = 2

'U0A vers V2

For i = 2 To 100

    If Right(Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i), 2) = "_2" Then
        
        Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Range("A" & n).Value = Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").Range("A" & i).Value

        Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Range("A" & n).Font.Color = RGB(200, 0, 200)

       n = n +1
       
    End If
    
Next i

End Sub

Peut-être ça ?

Dans tous les cas, c'est comme d'hab, travailler sans fichier exemple, c'est comme travailler les yeux bandés.
 

xUpsilon

XLDnaute Accro
Bonjour decga, JM, xUpsilon,

Au post #6 je ne vois rien qui enlève les "_2" !

Et pour supprimer des lignes, classiquement la boucle doit commencer par la dernière ligne et remonter vers la 1ère.

A+

Effectivement il manque la ligne pour le "_2" je n'avais pas vu.
Pour la suppression des lignes, si c'est dans le fichier source je dis pas, mais si c'est juste pour supprimer des lignes vides engendrées par une copie mal gérée (copie de la ligne i sur la ligne i de l'autre classeur plutot que sur une n indépendante) à ce moment là il vaut mieux simplement mieux écrire le code (en passant par un n), ça éviterait de rajouter une boucle (bien que ton intervention soit tout à fait exacte ;) )

Bonne continuation

PS : Histoire que notre ami @decga n'oublie pas : Joignez nous un fichier exemple nom de dieu.
 

job75

XLDnaute Barbatruc
Avec ce code c'est plus simple et plus rapide sur un grand tableau :
VB:
Sub Traction_V2()
Application.ScreenUpdating = False
With Workbooks("Traction_V2.xlsm").Worksheets("Position VI").Columns(1)
    .Clear 'RAZ
    With Workbooks("Traction ligne UA0.xlsm").Worksheets("Position VI").UsedRange.Columns(1)
        .AutoFilter 1, "*_2" 'filtre automatiqye
        .Copy Workbooks("Traction_V2.xlsm").Worksheets("Position VI").[A1]
        .AutoFilter 'retire le filtre
    End With
    .Replace "_2", ""
    .Cells(2).Resize(.Rows.Count - 1).Font.Color = RGB(200, 0, 200)
    .Parent.Activate 'facultatif
End With
End Sub
 

job75

XLDnaute Barbatruc
En utilisant un tableau VBA ce sera très rapide même si le tableau source fait plusieurs dizaines de milliers de lignes :
VB:
Sub Traction_V2()
Dim tablo, nlig&, n&, i&, x$
With Workbooks("Traction ligne UA0.xlsm").Sheets("Position VI").UsedRange.Columns(1)
    nlig = .Rows.Count
    If nlig = 1 Then nlig = 2 'au moins 2 cellules
    tablo = .Resize(nlig) 'matrice, plus rapide
End With
n = 1
For i = 2 To nlig
    x = tablo(i, 1)
    If Right(x, 2) = "_2" Then n = n + 1: tablo(n, 1) = Left(x, Len(x) - 2)
Next
'---restitution---
With Workbooks("Traction_V2.xlsm").Sheets("Position VI")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1]
        .Resize(n) = tablo
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
        .Cells(2).Resize(.Parent.Rows.Count - .Row).Font.Color = RGB(200, 0, 200)
    End With
    .Activate 'facultatif
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
 

job75

XLDnaute Barbatruc
La dernière macro adaptée pour 3 colonnes :
VB:
Sub Traction_V2()
Dim tablo, n&, i&, x$
tablo = Workbooks("Traction ligne UA0.xlsm").Sheets("Position VI").UsedRange.Columns("A:C")
n = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If Right(x, 2) = "_2" Then n = n + 1: tablo(n, 1) = Left(x, Len(x) - 2): tablo(n, 2) = tablo(i, 2): tablo(n, 3) = tablo(i, 3)
Next
'---restitution---
With Workbooks("Traction_V2.xlsm").Sheets("Position VI")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1]
        .Resize(n, 3) = tablo
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 3).Delete xlUp 'RAZ en dessous
        .Cells(2).Resize(.Parent.Rows.Count - .Row, 3).Font.Color = RGB(200, 0, 200)
    End With
    .Activate 'facultatif
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 789
Membres
101 817
dernier inscrit
carvajal