XL 2016 répéter ce code VBA (faire une boucle) (résolu)

Fab71 · 21 Juin 2018

Bon excusez moi si la question parait simple ou déjà mainte fois demandé ...

Mais dans un tableau j'ai 2 colonnes A et B donc et je cherche une valeur en A, si elle existe je recupere la valeur (texte) sur la colonne B sur laquelle je supprime des caracteres

j'ai fais ce code (bon je débute et progresse pas vite lol), il fonctionne pour une recherche mais j'aimerais qu'il fasse cela sur toute la colonne

Sub remplacement()
'
Columns("A:A").Select

Cells.Find(What:="meilleur").Offset(0, 1).Select

nouveaunom = Left(ActiveCell, Len(ActiveCell) - 13)

Selection.Value = nouveaunom

End Sub

En vous remerciant par avance

job75 · 21 Juin 2018

Bonjour Fab71,

Testez ces 2 macros et retenez celle que vous voulez quand n < 13 :

Code:

Sub Remplacement1()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If LCase(tablo(i, 1)) Like "*meilleur*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13)
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Resize(, 2) = tablo
End With
End Sub

Sub Remplacement2()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If LCase(tablo(i, 1)) Like "*meilleur*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13) Else tablo(i, 2) = ""
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Resize(, 2) = tablo
End With
End Sub

A+

Fab71 · 21 Juin 2018

merci j'arrive a dechiffré et plus ou moins comprendre le raisonnement.

cependant je n'ai rien qui change dans mon tableau

je joints le fichier ce sera plus simple (la recherche se fait sur "Best lap") et le but est d'effacer les 13 derniers caractères systématiquement dans la colonne B

job75 · 21 Juin 2018

Re,

2 choses n'allaient pas sur votre fichier :

1) vous n'avez pas compris que j'utilise LCase pour que la casse soit ignorée donc il faut écrire "*best lap*" en minuscules

2) en A19 et A60 il y a '====================== qui crée un bug à la 2ème exécution de la macro car l'apostrophe saute.

Utilisez donc ces codes :

Code:

Sub Remplacement1()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If Left(tablo(i, 1), 1) = "=" Then tablo(i, 1) = "'" & tablo(i, 1) 'apostrophe devant =
        If LCase(tablo(i, 1)) Like "*best lap*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13)
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Resize(, 2) = tablo
End With
End Sub

Sub Remplacement2()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If Left(tablo(i, 1), 1) = "=" Then tablo(i, 1) = "'" & tablo(i, 1) 'apostrophe devant =
        If LCase(tablo(i, 1)) Like "*best lap*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13) Else tablo(i, 2) = ""
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Resize(, 2) = tablo
End With
End Sub

Fichier corrigé joint.

A+

Fab71 · 21 Juin 2018

Je ne sais comment dire .... MERCI
je vais regarder de plus près et essayer de tout comprendre, je me permets de revenir en cas de besoin d'explication ...

Encore Merci a vous

job75 · 21 Juin 2018

Re,

En restituant seulement la 2ème colonne il n'y a plus de problème avec A19 et A60 :

Code:

Sub Remplacement1()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If LCase(tablo(i, 1)) Like "*best lap*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13)
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Columns(2) = Application.Index(tablo, , 2) 'restitution de la 2ème colonne
End With
End Sub

Sub Remplacement2()
Dim tablo, i&, n%
With ActiveSheet
    tablo = .UsedRange.Resize(, 2) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If LCase(tablo(i, 1)) Like "*best lap*" Then n = Len(tablo(i, 2)): _
            If n > 12 Then tablo(i, 2) = Left(tablo(i, 2), n - 13) Else tablo(i, 2) = ""
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .UsedRange.Columns(2) = Application.Index(tablo, , 2) 'restitution de la 2ème colonne
End With
End Sub

Fichier (2).

Nota : dans le fichier (1) la dernière cellule (touche F5) était R806.

J'ai donc supprimé les lignes 83:806 et les colonnes C:R, l'exécution est bien sûr plus rapide.

A+

Paritec · 22 Juin 2018

Bonjour Job75 fab71 le forum

Je ne sais comment dire .... MERCI

Pour apprendre à dire merci, je ne sais pas , mais tu pourrais peut-être déjà apprendre à dire bonjour dans tes posts
bonne journée
Papou

job75 · 22 Juin 2018

Bonjour Fab71, Papou, le forum,

Concernant le nettoyage d'un fichier Fab71 m'a fait parvenir ce message privé :

petite question, comment nettoyer correctement ?
je m'explique si je fais effacer (une simple selection puis supp) ca reste identique
si je supprime les lignes ca fonctionne mais je ne veux pas employer cette methode car si j'ai des plages definies elles sont modifiées.

plages définies : je comprends qu'il s'agit de plages nommées, il suffit de les mémoriser avant le nettoyage :

Code:

Sub Nettoyer()
Dim LastCell As Range, a$(), i&, derlig&, dercol%
With ActiveSheet
    Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
    MsgBox LastCell.Address(0, 0) & " : dernière cellule avant nettoyage", , "Nettoyer"
    '---mémorisation des noms définis---
    ReDim a(1 To ThisWorkbook.Names.Count, 1 To 2)
    For i = 1 To UBound(a)
        a(i, 1) = ThisWorkbook.Names(i).Name
        a(i, 2) = ThisWorkbook.Names(i).RefersTo
    Next
    '---réduction du UsedRange---
    On Error Resume Next 's'il n'y a aucune donnée dans la feuille
    derlig = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    dercol = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    .Rows(derlig + 1).Resize(.Rows.Count - derlig).Delete
    .Columns(dercol + 1).Resize(, .Columns.Count - dercol).Delete
    '---restitution des noms définis---
    For i = 1 To UBound(a)
        ThisWorkbook.Names.Add a(i, 1), a(i, 2)
    Next
    '---dernière cellule---
    With .UsedRange: End With 'actualisation du UsedRange
    Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
    MsgBox LastCell.Address(0, 0) & " : dernière cellule après nettoyage", , "Nettoyer"
End With
End Sub

Fichier joint.

Bonne journée.

Fab71 · 22 Juin 2018

merci a toi et bonne fin de journée également, je vais me plonger dans tes macros....
j'ai du boulot lol

XL 2016 répéter ce code VBA (faire une boucle) (résolu)

Fab71

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Fab71

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Fab71

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Paritec

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Fab71

XLDnaute Nouveau

Discussions similaires