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

Fab71

XLDnaute Nouveau
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

XLDnaute Barbatruc
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

XLDnaute Nouveau
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
 

Pièces jointes

  • test macro.xlsm
    33.5 KB · Affichages: 19

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • test macro(1).xlsm
    37 KB · Affichages: 14

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • test macro(2).xlsm
    32.5 KB · Affichages: 18

job75

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Nettoyer(1).xlsm
    26.7 KB · Affichages: 22
Dernière édition:

Discussions similaires

Réponses
4
Affichages
792

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof