Récupération et traitement de certaines cellules dans un classeur

Bonjour à tous

Je souhaite récupérer la totalité des cellules qui contiennent un % dans plusieurs onglets d'un classeur.

Ces cellules doivent subir un nettoyage (suppression des 6 derniers caractères et des 10 premiers caractères)

Exemples :
%0081100116A2049033336801250 devient 6A2049033336
%0029420119L2049150005801250 devient 9L2049150005

Toutes les cellules doivent se ranger dans un nouvel onglet ou classeur sous forme de liste (cf exemple dans le fichier ci-joint)

Suite à plusieurs tentatives (cf code dans le fichier ci-joint), le code n'emporte pas la première cellule détectée de chaque tableau trouvé

Demande supplémentaire : est ce que l'extraction peut s'enregistrer dans un autre fichier excel dans le même répertoire
Le nom du nouveau fichier serait le même avec ajout de la date du jour.

Question subsidiaire : est il possible de lancer la macro depuis un fichier Excel => ouverture d'une invitation pour choisir le fichier à traiter => traitement => et production/enregistrement du fichier en sortie (c’est-à-dire : ne pas à avoir à ramener la macro dans le classeur à traiter)

Demande facultative : affichage d'un compteur qui visualise le nombre de traitement en cours. Avec un clap de fin quand tout est fini (certains de mes fichiers contiennent plusieurs dizaines de milliers de cellules à récupérer...)

Merci par avance pour votre aide. Cet outil me sera grandement utile (nombreux fichiers à traiter !)

Bonjour,

Voici une proposition de code qui devrait répondre à l'ensemble de vos demandes :

Sub test()
wbname$ = application.getopenfilename()
if not wbname like "*.xlsx" then exit sub
t = Nettoyer(wbname)
if not isarray(t) then msgbox "aucune correspondance", 16: exit sub
with workbooks.add
    with .sheets(1)
        .cells(1, 1).value = "Liste"
        .cells(2, 1).resize(ubound(t)).value = t
        .listobjects.add source:=.usedrange, xllistobjecthasheaders:=xlyes
    end with
    sfilename$ = replace(wbname, ".xlsx", "") & " " & format(now, "YYMMDD HHMMSS") & ".xlsx"
    .saveas sfilename, 51
    .close true
end with
end sub

function Nettoyer(sfilename$)
dim t()
with workbooks.open(sfilename)
    for each ws in .worksheets
        on error resume next
        temp = ws.usedrange.value2
        if err.number <> 0 then
            on error goto 0
        else
            for each elem in temp
                if elem like "*%*" then
                    n = n + 1
                    redim preserve t(1 to n)
                    t(n) = mid(elem, 11, len(elem) - 16)
                end if
            next elem
        end if
    next ws
    .close false
end with
if n > 0 then Nettoyer = application.transpose(t)
end function

La présente macro affiche une boite de dialogue de sélection de fichiers permettant d'ouvrir le fichier à manipuler (celui-ci doit être fermé au moment de l'exécution du code), puis retient et transforme les valeurs contenant "%" afin de les lister dans un nouveau classeur.

Cdlt,

Edit : Code édité ! Merci de me tenir informé ici des résultats des essais

Parfait !

Merci beaucoup

Je t'en prie ! Alors, tu as pu essayer ?

Malheureusement : j'ai une importante perte de données entre le fichier d'entrée (plusieurs dizaine de milliers de cellules à capter et le fichier de sortie qui ne compte que 12 000 cellules et quelques)

Oui, mais n'est ce pas normal ? Pour rappel, la macro ne retient que les valeurs contenant un % et je doute qu'elle en manque certaines.

Après plusieurs tests : le fichier de sortie est erroné dès que le nombre dépasse 65OOO cellules à retranscrire (ne retient que 12000 cellules si 77000 au total par exemple)

PS : le résultat peut se faire dans plusieurs onglets si c'est le problème

Ce n'est pas un problème d'onglet mais de tableau et de mémoire disponible apparemment...

Il faudrait utiliser plusieurs tableaux... Je ferai un essai avant en utilisant une autre méthode pour voir ce qu'il en est.

Merci ! J'attend le retour.

Précision : la récupération des cellules peut se faire dans plusieurs onglets si besoin.

Bonjour Filipe,

Voici un essai en réinitialisant le tableau en mémoire qui stocke les données tous les 1000 éléments (on peut supposer que ce nombre pourrait être élevé à 12000 éléments) :

Sub test()

redim t(1 to 1000, 1 to 1)
wbname$ = application.getopenfilename() 'nom fichier source
if not wbname like "*.xlsx" then exit sub
'ouverture et initialisation fichier destination
set wsdest = workbooks.add.sheets(1)
wsdest.cells(1, 1).value = "Liste"
'avec fichier source
with workbooks.open(wbname)
    'on parcourt toutes les cellules (propriété .value2) de chaque feuille
    for each ws in .worksheets
        for each cell in ws.usedrange.value2
            if cell like "*%*" then
                n = n + 1
                t(n, 1) = mid(cell, 11, len(cell) - 16) 'on alimente le tableau quand condition remplie
                'on colle et reset le tableau tous les 1000 éléments
                if n = 1000 then
                    with wsdest
                        nvl = .cells(.rows.count, 1).end(xlup).row + 1
                        .cells(nvl, 1).resize(1000).value = t
                    end with
                    n = 0: erase t: redim t(1 to 1000, 1 to 1)
                end if
            end if
        next cell
    next ws
    .close false
end with
with wsdest 'avec feuille destination
    nvl = .cells(.rows.count, 1).end(xlup).row + 1
    if t(1, 1) <> "" then .cells(nvl, 1).resize(1000).value = t 'collage dernier tableau
    .listobjects.add source:=.usedrange, xllistobjecthasheaders:=xlyes
    sfilename$ = replace(wbname, ".xlsx", "") & " " & format(now, "YYMMDD HHMMSS") & ".xlsx"
    .parent.saveas sfilename, 51
    .close true
end with
end sub

Comme je l'ai dit, ce ne sont pas les onglets qui posent problème...

Il faut déjà voir si ce code fonctionne. J'ai d'autres idées mais qui rallongeraient considérablement le temps d'exécution...

Cdlt,

Un essai au cas où avec l'ancien code en contournant la transposition de l'objet worksheetfunction :

Sub test()
wbname$ = application.getopenfilename()
if not wbname like "*.xlsx" then exit sub
t = Nettoyer(wbname)
if not isarray(t) then msgbox "aucune correspondance", 16: exit sub
with workbooks.add
    with .sheets(1)
        .cells(1, 1).value = "Liste"
        .cells(2, 1).resize(ubound(t)).value = t
        .listobjects.add source:=.usedrange, xllistobjecthasheaders:=xlyes
    end with
    sfilename$ = replace(wbname, ".xlsx", "") & " " & format(now, "YYMMDD HHMMSS") & ".xlsx"
    .saveas sfilename, 51
    .close true
end with
end sub

function Nettoyer(sfilename$)
dim t()
with workbooks.open(sfilename)
    for each ws in .worksheets
        on error resume next
        temp = ws.usedrange.value2
        if err.number <> 0 then
            on error goto 0
        else
            for each elem in temp
                if elem like "*%*" then
                    n = n + 1
                    redim preserve t(1 to 1, 1 to n)
                    t(1, n) = mid(elem, 11, len(elem) - 16)
                end if
            next elem
        end if
    next ws
    .close false
end with
if n > 0 then Nettoyer = Transpose(t)
end function

function Transpose(t)
redim temp(1 to ubound(t,2), 1 to ubound(t))
for i = lbound(t) to ubound(t)
    for k = lbound(t,2) to ubound(t,2)
        temp(k, i) = t(i, k)
    next k
next i
Transpose = temp
end function

Cdlt,

Parfait.

Juste modifié/corrigé : .Close True par .Parent.Close True pour éviter une erreur

Super, merci du retour !

Cdlt,