Macro ou code pour supprimer ligne et terme de cellules
Bonsoir
Y aurait t il une macro ou une ligne de code qui me permettrait de trier de la sorte une base de donnée comportant plusieurs milliers de ligne. Tout se situe en Colonne A
supprimer systématiquement l'ensemble de la ligne qui débute par Lieu et montant
Ne conserver que celle intituler référence: mais en supprimer uniquement le terme "référence:" conserver le restant de la cellule
en image ça donne ca
Merci d'avance pour votre aide précieuse je n'ai aucune idée sur le comment y parvenir vu l'ampleur de la base pas le choix que de l'automatiser.
J'ai tenté de bricoler ces quelques lignes, peut être pas besoin d'une macro pour cela mais bien entendu çà ne marche pas
=STXT(SUBSTITUE(SUBSTITUE(A4;"Adresse:";"";[A4];A5;"";"";[A5];A6;"";"")))Systématiquement j'ai besoin de supprimer les deux lignes complète figurant sous adresse sur l'ensemble des lignes de la colonne A / seul élément de la cellule à conserver est la partie aprés Adresse: mais rien n'y fait je n'y parviens pas .
Je vous joint le fichier si ca peut aider, en attendant vos retour un grand merci
Bonjour,
C'est mes yeux ... ou la demande du premier message ... n'est pas la demande du deuxième message ...
En attendant ... ton fichier avec la formule demandée ...
Bonjour,
On parle de plusieurs milliers de lignes.
Une proposition VBA à étudier.
Attention !
La procédure remplace en lieu et place les données existantes.
Cdlt.
Option Explicit
Public Sub Clear_Data()
Dim ws As Worksheet
Dim N As Long, I As Long, k As Long
Dim tbl As Variant
Dim Arr() As String
Set ws = ActiveSheet
With ws
N = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(3, 1).Resize(N - 2)
tbl = .Value
.ClearContents
End With
For I = 1 To UBound(tbl)
If Left(tbl(I, 1), 3) = "réf" Then
ReDim Preserve Arr(1, k + 1)
Arr(0, k) = Trim(Split(tbl(I, 1), ":")(1))
k = k + 1
End If
Next I
If k > 0 Then .Cells(3, 1).Resize(k).Value _
= Application.Transpose(Arr)
End With
Erase Arr: Set ws = Nothing
End SubMerci bien james007 mais le code ne supprime pas les 2 cellules du dessous hélas.
Pour le VBA l'idée est excellente Jean Eric ....sauf que ca supprime tout, la feuille devient blanche, vierge de tout élément
Re,
Merci bien james007 mais le code ne supprime pas les 2 cellules du dessous hélas.
Rien de plus normal ... la formule ne sert qu'à extraire du texte de ta cellule ... elle ne pourra jamais supprimer des lignes ....
A propos de la suppression des lignes .... comme tes deux premiers messages ne disent pas la même chose ...
Peux-tu clarifier ce qui est à supprimer ...
Hi,
De tête, en pas optimisé et à tester :
sub supp_ligne
Dim derligne%, i%
application.screenupdating = false
application.displaystatusbar=false
application.calculation= xlcalculationmanual
with thisworkbook.activesheet
derligne = .range("A" & rows.count).end(xlup).row 'On défini la dernière ligne de la colonne A
For i = derligne to 1 step -1 'Soit i un chiffre allant de 1 à la dernière ligne, et on part de la dernière ligne pour remonter en haut de la colonne
If Left(.range("A" & i).value, 4) = "Lieu" or left(.range("A" & i).value, 7) = "montant" then 'Si les 4 ou 7 premiers caractères de la cellule sont respectivement Lieu ou montant
.Rows(i).EntireRow.Delete Shift:=xlUp 'on supprime la ligne
end if
if left(.range("A" & i).value,9) = "référence" then
.Range("A" & i).Value = Replace(.Range("A" & i).Value, "référence: ", "") 'on remplace le mot "référence: "(double point et espace compris) par rien du tout
end if
next i
end with
calculate
application.screenupdating = true
application.displaystatusbar=true
application.calculation= xlcalculationautomatic
end subEdith : C'est globalement la solution proposée par Jean-Eric, mais en bien moins rapide (pas d'utilisation des tableaux), et plus simple à comprendre (si tu n'es pas trop familier du VBA).
Edith² : Bon j'ai testé sur ton fichier (en remplaçant Lieu par Adresse et montant par Montant (bien respecter les majuscules, accents, etc...), ça marche. Si tu changes les mots visés, penses à changer le nombre de caractères dans les "Left(mon_mot, mon_nombre_de_caractères)"
Superbe Kit c'est pil poil ce dont j'avais besoin, c'est hallucinant d'efficacité j'aurais pu y passer 10 jours que je ne serais jamais arrivé à un tel résu en plus ca me comble les lignes vides auto ....bref parfait, chapeau bas
Merci à tous les contributeur pour la participation à cette file et encore bravo kit, j'ai juste adapté comme tu m'as dis la ligne left
Je passe le sujet en résolu
De rien, pour une fois que j'apporte de l'aide au lieu de venir en chercher
Note cependant que la version utilisant les variables tableau sera bien plus rapide à s'exécuter.
Effectivement le code de Jean-Eric serait peut-être plus optimisé et rapide pour ce genre de tache sauf que je le comprend moins et ne vois pas où apporter les modification car en l'état il me supprime tout.
je remet le code de Jean Eric et en dessous je joint le fichier avec le code de kit qui fonctionne sur la feuil1 en mode test peu de données mais qui plante en Feuil2
Option Explicit
Public Sub Clear_Data()
Dim ws As Worksheet
Dim N As Long, I As Long, k As Long
Dim tbl As Variant
Dim Arr() As String
Set ws = ActiveSheet
With ws
N = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(3, 1).Resize(N - 2)
tbl = .Value
.ClearContents
End With
For I = 1 To UBound(tbl)
If Left(tbl(I, 1), 3) = "réf" Then
ReDim Preserve Arr(1, k + 1)
Arr(0, k) = Trim(Split(tbl(I, 1), ":")(1))
k = k + 1
End If
Next I
If k > 0 Then .Cells(3, 1).Resize(k).Value _
= Application.Transpose(Arr)
End With
Erase Arr: Set ws = Nothing
End SubCe code doit être plus veloce mais qu'est ce qui fait qu'il m'efface tout?
Bonjour ericjuju, le fil, Jean-Eic, James007...
Voici une proposition...
Sub Tasser()
Dim ligFin, ligCpt, nbrLig
Dim tabVrac(), tabGood()
Dim tmp
ligFin = Cells(Rows.Count, 1).End(xlUp).Row
nbrLig = 0
tabVrac = Range(Cells(1, 1), Cells(ligFin, 1))
ReDim tabGood(1 To 1, 1 To 1)
For ligCpt = 1 To UBound(tabVrac, 1)
If Left(tabVrac(ligCpt, 1), 3) = "Réf" Then
nbrLig = nbrLig + 1
ReDim Preserve tabGood(1 To 1, 1 To nbrLig)
tmp = Split(tabVrac(ligCpt, 1), ":")
tabGood(1, nbrLig) = tmp(1)
End If
Next
Cells.ClearContents
Cells(1, 1).Resize(UBound(tabGood, 2), UBound(tabGood, 1)) = WorksheetFunction.Transpose(tabGood)
End SubBonjour,
La même proposition révisée.
Cdlt.
Option Explicit
Public Sub Clear_Data()
Dim N As Long, I As Long, k As Long
Dim tbl As Variant, Arr() As String
With ActiveSheet
N = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(3, 1).Resize(N - 2)
tbl = .Value
.ClearContents
End With
For I = 1 To UBound(tbl)
If Left(tbl(I, 1), 3) = "Réf" Then
ReDim Preserve Arr(1, k + 1)
Arr(0, k) = Trim(Split(tbl(I, 1), ":")(1))
k = k + 1
End If
Next I
.Cells(3, 1).Resize(k).Value = Application.Transpose(Arr)
End With
End SubSalut,
Si tu as plusieurs dizaines de milliers de lignes, l'erreur vient du fait que j'ai déclaré i et derligne comme Integer (ou abrévié en %). Integer peut prendre un nombre allant jusqu'à 2^15, soit 32 768. Pour aller au delà, il faut utiliser Long à la place d'Integer. Long peut être abrévié en & (sinon tu remplaces par i as long, derligne as long).
Merci pour ces deux derniers codes Jean-Eric et NCC 1701 ils fonctionnent parfaitement et sont ultra rapide
Le tien également Kit même si un peu moins véloce que les 2 précédents,je le comprends parfaitement.
Du coup Jean-Eric et NCC pourriez vous m'expliquer les vôtres dans la mesure où si je dois l'adapter à d'autres tableau qui se configure de la même manière mais où je devrais cette fois ci garder uniquement le contenu de la 1er ou de la seconde cellule sans son préfixe et effacer entiérement les deux autres cellules comment faire sur quel variable du code je dois jouer.
Voir par exemple ce tableau ci joint le code de NCC comme de Jean ERIC va très bien mais si je cherche à l'adapter sur celui-ci de nouveau tout s'efface donc quel variable ajuster par exemple sur le tableau joint pour ne conserver que la partie Référentiel (sans le terme référentiel) et supprimer l'ensemble des 2 autres cellule à savoir identifiant et montant.
Bonjour ericjuju, Jean-Eric, tous...
Explication du code pourquoi pas... mais ne serait-il pas plus simple d'envoyer dès le début un fichier qui retrace la vraie réalité du cas ?
Bref, les explications dans le code
Sub Tasser()
' Les variables
' ligFin pour trouver la derniere ligne à traiter
' ligCpt pour compter les lignes
' ligNbr pour savoir combien de lignes sont conservées
'
' tabVrac() un tableau pour lire le fichier tel qu'il se présente au debut
' tabGood() le tableau qui sera le resultat épuré !
'
' tmp un "faux" tableau pour la fonction Split => voir dans le code
Dim ligFin, ligCpt, nbrLig
Dim tabVrac(), tabGood()
Dim tmp
' Rechercher la derniere ligne
ligFin = Cells(Rows.Count, 1).End(xlUp).Row
' Pour l'instant nous ne savons pas combien nous aurons de ligne au final
nbrLig = 0
' Initialiser le tableau du debut
' de la 1ere cellule (en haut à gauche ligne 1,colonne 1)
' jusqu'à la derniere que nous venons de trouver (ligne ligFin, colonne 1)
tabVrac = Range(Cells(1, 1), Cells(ligFin, 1))
' Preparer le tableau final
' ATTENTION ce tableau est à l'envers...
' il est en effet impossible de redimensionner autre chose que la dernière dimension d'un tableau
' Donc le tableau est inversé càd que
' Normalement Excel considère la 1ere dimension comme étant la ligne et la 2ème comme étant la colonne
' dans notre cas nous ne savons pas combien nous avons de ligne donc le tableau est inversé !
ReDim tabGood(1 To 1, 1 To 1)
' Parcourir le tableau
' du debut (1)
' jusqu'à la fin (ubound - sachant que 1 représente le nbre de lignes puisque ce tableau-ci n'est pas inversé
For ligCpt = 1 To UBound(tabVrac, 1)
' Si les 3 1er caracteres de la ligne en cours sont "Réf"
If Left(tabVrac(ligCpt, 1), 3) = "Réf" Then
' On peut ajouter une nouvelle ligne au tableau final
nbrLig = nbrLig + 1
' On redimensionne le tableau final en preservant l'ancien contenu (Preserve)
ReDim Preserve tabGood(1 To 1, 1 To nbrLig)
' On recherche le caractere ":" sur cette ligne
' on utilise le faux tableau tmp qui commene à 0 et découpe la chaine
' en autant de fois que le caractere ":" est present
' dans notre cas ce devrais être 2
tmp = Split(tabVrac(ligCpt, 1), ":")
' Nous pouvons alimenter le tableau final
' et nous prenons donc la position 1 du faux tableau (puisque c'est la 2ème en partant de zero)
tabGood(1, nbrLig) = tmp(1)
' Et c'est tout !
End If
' On peut passer à la ligne suivante
Next
' On efface les anciennes données (toutes)
Cells.ClearContents
' On redimensionne la 1ère cellule au dimension du tableau final
' ATTENTION
' le redimensionnement est virtuel
' la fonction Resize permet de créer un Range (un groupe de cellule)
' ATTENTION BIS
' comme notre tableau final est inversé nous inversons aussi les dimensions
' ubound(tabGood,2) represente les lignes et non les colonnes
' ubound(tabGood,1) represente les colonnes et non les lignes
' ET ENFIN
' utilisation de la fonction Transpose pour remettre le tableau dans le bon sens
Cells(1, 1).Resize(UBound(tabGood, 2), UBound(tabGood, 1)) = WorksheetFunction.Transpose(tabGood)
' Fin
End Sub
' Comment adapter ?
' en supposant qu'il y a plusieurs colonnes à traiter :
'
' il suffit :
' 1) de changer la ligne suivante au nombre de colonnes à traiter le dernier 1 apres ligFin
' tabVrac = Range(Cells(1, 1), Cells(ligFin, 1))
' 2) de changer les dimensions du tableau final a ce nombre de colonne
' ReDim tabGood(1 To 1, 1 To 1)
' ATTENTION a l'inversion - il faut ici changer le 2ème 1 - après le 1er To
' puisque celui-ci represente les colonnes et non les lignes (cf. remarque dans le code)
'
' 3) d'ajouter un autre boucle pour parcourir les colonnes (à l'interieur de la 1ere boucle)
' For ligCpt = 1 To UBound(tabVrac, 1)
' For colCpt = 1 To Ubound(tabVrac,2) <= à ajouter pour parcourir les colonnes
' If Left(tabVrac(ligCpt, 1), 3) = "Réf" Then <= à modifier en
' If Left(tabVrac(ligCpt, colCpt) = "Réf" Then (pour traiter toutes les colonnes)
' ReDim Preserve tabGood(1 To 1, 1 To nbrLig) <= à modifier en
' Redim Preserve tabGood(1 to x, 1 To nbrLig) (ou x est le nb de colonnes à traiter)
' tmp = Split(tabVrac(ligCpt, 1), ":") <= à modifier en
' tmp = Split(tabVrac(ligCpt, x), ":") (ou x est idem)
' tabGood(1, nbrLig) = tmp(1) <= à modifier en
' tabGood(x, nbrLig) = tmp(1) (idem pour x)
' 4) ajouter un Next avant le 1er(re)
ericjuju a écrit :Voir par exemple ce tableau ci joint le code de NCC comme de Jean ERIC va très bien mais si je cherche à l'adapter sur celui-ci de nouveau tout s'efface donc quel variable ajuster par exemple sur le tableau joint pour ne conserver que la partie Référentiel (sans le terme référentiel) et supprimer l'ensemble des 2 autres cellule à savoir identifiant et montant.
je pense qu'il y a erreur de compréhension et de termes
Lorsque je lis "supprimer" je supprime ! alors que tu as l'air de dire qu'il fat mettre à blanc (ce qui n'est pas tout à fait pareil) !
Nous faisons :
ID:MACHIN 1
Ref:BIDULE 1
Mt:MT 1
ID:MACHIN 2
Ref:BIDULE 2
Mt:MT 2
Devient
BIDULE 1
BIDULE 2
Alors que tu voudrais
ligne vide (ancien MACHIN 1)
BIDULE 1
ligne vide (ancien MT 1)
ligne vide (ancien MACHIN 2)
BIDULE 2
ligne vide (ancien MT 2)
Est-ce cela ?
En faite NCC je voudrais qu'il ne reste que ce que j'ai marqué en jaune, je trouve ton code topissime car super rapide mais je viens de prendre 2 aspirine en essayant de le modifier pour l'adapter j'y arrive pas
en faite comme sur la capture je souhaite qu'il ne conserve que cette partie à chaque fois sur X dizaines de milliers de lignes
Bonjour
voila un test de transfert sur une autre Feuille
a toi de voir
A+
Maurice
Merci acher il me m'inscrit erreur de compilation / variable non défini pour L/
(re)
ericjuju a écrit :je trouve ton code topissime car super rapide
ericjuju a écrit :mais je viens de prendre 2 aspirines
Arrête de prendre ça, c'est pas bon !
Par contre je reformule "je crois que nous avons du mal à comprendre le besoin que tu as du mal à exprimer"
oui voilà c'est tout à fait ca NCC je voudrais quand j'exécute ton code le résu qui figure colonne 3, uniquement ca