Copier et transposer avec boucles et détection de cellule semblable
Bonjour,
Etant débutant sur VBA, j'ai voulu faire un copier et transposer avec l'enregistreur de macro mais j'y arrive pas du tout. Donc si quelqu'un peut m'aider sur ce sujet, je vous en serais vraiment reconnaissant.
En gros, j'ai des données sur la colonne A. Et je veux copier les cellules contenant les mêmes 6 premières caractères et les coller et transposer sur la cellule C. Et le faire en boucle pour copier-coller la suite.
A noter que les cellules contenant les mêmes 6 premières caractères peuvent varier.
Exemple du fichier Excel sans traitement:
Et le résultat attendu:
Si vous pouvez m'aider SVP à réaliser le code VBA pour faire cela car j'ai déjà perdu beaucoup de temps à se documenter et essayer mais en vain.
Bien cordialement
Herchel
Bonjour,
Voici un essai avec des données triées :
sub test()
with activesheet
for i = 1 to .usedrange.columns(1).count
if racine = "" then racine = left(.cells(i,1).value, 6)
if .cells(i, 1).value like racine & "*" then
n = n + 1: redim preserve t(1 to n)
t(n) = .cells(i, 1).value
end if
if not .Cells(i + 1).value like racine & "*" then
nvl = nvl + 1
.cells(nvl, 3).resize(1, n) = t
racine = "": n = 0
end if
next i
end with
end subCdlt,
Bonjour 3G,
Merci bien pour votre réponse. J'ai un erreur: Variable non définie lorsque j'exécute.
Donc je suis pas arriver à avoir le résultat de ton formule.
Bien cordialement
Herchel
Bonjour,
Désolé, c'est un oubli de ma part. Voici le code avec les variables déclarées :
sub test()
dim t(), i&, n&, nvl&, racine$
with activesheet
for i = 1 to .usedrange.columns(1).count
if racine = "" then racine = left(.cells(i,1).value, 6)
if .cells(i, 1).value like racine & "*" then
n = n + 1: redim preserve t(1 to n)
t(n) = .cells(i, 1).value
end if
if not .Cells(i + 1).value like racine & "*" then
nvl = nvl + 1
.cells(nvl, 3).resize(1, n) = t
racine = "": n = 0
end if
next i
end with
end subCdlt,