Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Comment faire une copie rapide des noms

Comment faire une copie rapide des noms

7 réponses
Avatar
Bartez
Bonjour à tous,

J'ai écrit le code suivant qui fonctionne très bien mais qui est
relativement lent.
J'ai découvert ce matin qu'une procedure VBA bien consue, comme celle que
m'a fait passer Michdeni, pouvait être Hyper rapide et efficace donc je me
suis dit que peut être il serait possible d'améliorer sensiblement
celle-ci.;-)

Je recherche donc plus un avi pour m'améliorer qu'un code tout fait.
Si un de vous (Ceux qui maitrisent les méandres obscures du VBA) avait une
idée ou un conseil pour que je puisse accélérer la vitesse d'exécution de
cette boucle, je suis preneur !

Private Sub Copier_les_Noms_et_leurs_Étiquettes()
Dim Mois As Object
Dim Nom_à_Définir As Object
Dim Nom_à_Inscrire As String

For Each Mois In Worksheets
For Each Nom_à_Définir In Sheets(Worksheets.Count).Names

'définir le nom
Nom_à_Inscrire = Right(Nom_à_Définir.Name, Len(Nom_à_Définir.Name)
_
-InStr(1, Nom_à_Définir.Name, "!"))
Sheets(Mois.Name).Names.Add _
Name:=Nom_à_Inscrire, _
RefersTo:="='" & Mois.Name & "'!" &
Range(Nom_à_Définir).Address

'si le nom est dans la colonne CB (donc 80), copier aussi
l'étiquette
If Range(Nom_à_Définir).Column = 80 Then
'écrire l'étiquette en face du nom à définir
Sheets(Mois.Name).Range(Range(Nom_à_Inscrire).Address).Offset(0,
-1).Value _
=
Sheets(Worksheets.Count).Range(Range(Nom_à_Inscrire).Address).Offset(0, -1).Value
End If

Next Nom_à_Définir

Next Mois

End Sub

Merci de votre aide
@+
Bartez
Signaler un problème avec ce contenu

7 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
michdenis
Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub
Avatar
Bartez
Bonjour Michdenis,

Alors que je viens tout juste de rentrer de weekend, je vois que vous avez
encore une fois travaillé pour moi !

Je n'ai pas le temps ce soir de tester votre code, mais demain je compte
bien l'essayer et surtout le comprendre.

Je reviendrais sur le forum pour vous donner des nouvelles, en tout cas je
vous remerci déjà pour votre aide.

@+
Bartez

"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub






Avatar
Bartez
Bonjour Michdenis,

Je viens de tester le code que tu as retouché et curieusement, alors que sur
un classeur standard, ça fonctionne très bien et très rapidement, sur mon
classeur perso, j'obtiens un erreur à la ligne

.Range(.Name & "!" & Adr).Name = NouveauNom

Le débogueur me dit :
"la méthode 'Range' de l'objet '_Worksheet' a échoué"

Je ne comprends pas ce qui peut le déranger alors que cette même ligne ne
pose aucun problème comme je l'ai dit sur un nouveau classeur.

Aurais-tu une idée sur le problème ?

Je pensais peut être que cela pouvait venir de la protections des feuilles
ou du classeur, mais même tout déprotégé l'erreur est toujours présente ;-)

@+
Bartez


"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub






Avatar
Bartez
Je viens de trouver pourquoi ça bloque.

Dans mon classeur, les feuilles sont nommées sous cette forme :
Modèle17(4-2006)

si je change et que je les nomment de façon standard :
Feuil4(Feuil4)

dans ce cas, tout fonctionne

Existe-il une modification à apporter au code pour qu'il puisse travailler
avec correctement avec le nom que j'ai affecté aux feuilles du classeur ?

@+
Bartez

"Bartez" a écrit dans le message de news:

Bonjour Michdenis,

Je viens de tester le code que tu as retouché et curieusement, alors que
sur un classeur standard, ça fonctionne très bien et très rapidement, sur
mon classeur perso, j'obtiens un erreur à la ligne

.Range(.Name & "!" & Adr).Name = NouveauNom

Le débogueur me dit :
"la méthode 'Range' de l'objet '_Worksheet' a échoué"

Je ne comprends pas ce qui peut le déranger alors que cette même ligne ne
pose aucun problème comme je l'ai dit sur un nouveau classeur.

Aurais-tu une idée sur le problème ?

Je pensais peut être que cela pouvait venir de la protections des feuilles
ou du classeur, mais même tout déprotégé l'erreur est toujours présente
;-)

@+
Bartez


"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub










Avatar
Bartez
Ok, j'ai trouvé :)

voici comment j'ai modifié les 2 lignes de code :

NouveauNom = "'" & .Name & "'" & "!" & Nom
.Range("'" & .Name & "'" & "!" & Adr).Name = NouveauNom

Cette fois, avec cette modification, ça fonctionne même avec mon classeur et
mes feuilles renommées.

Merci Michdenis, ton code est bien plus propre que le mien à l'origine.
Par contre pour la vitesse, ça ne m'a pas accéléré les choses.
Une boucle reste une boucle et il faut autant le même temps dans un sens
comme dans l'autre pour lire et écrire les 289 Noms contenus sur ma feuille.
Tanpis.

Ce qui aurrait été bien c'est de prendre comme pour la copies de cellules
(plage) tous les noms d'un coup, changer seulement l'origine de la feuille
"Feuil2!Nom1" devriendrait "Feuil1!Nom1" et de tout coller dans la Feuil1 en
évitant les boucles.

En tout cas, Merci encore de ton aide
@+
Bartez

"Bartez" a écrit dans le message de news:

Je viens de trouver pourquoi ça bloque.

Dans mon classeur, les feuilles sont nommées sous cette forme :
Modèle17(4-2006)

si je change et que je les nomment de façon standard :
Feuil4(Feuil4)

dans ce cas, tout fonctionne

Existe-il une modification à apporter au code pour qu'il puisse travailler
avec correctement avec le nom que j'ai affecté aux feuilles du classeur ?

@+
Bartez

"Bartez" a écrit dans le message de news:

Bonjour Michdenis,

Je viens de tester le code que tu as retouché et curieusement, alors que
sur un classeur standard, ça fonctionne très bien et très rapidement, sur
mon classeur perso, j'obtiens un erreur à la ligne

.Range(.Name & "!" & Adr).Name = NouveauNom

Le débogueur me dit :
"la méthode 'Range' de l'objet '_Worksheet' a échoué"

Je ne comprends pas ce qui peut le déranger alors que cette même ligne ne
pose aucun problème comme je l'ai dit sur un nouveau classeur.

Aurais-tu une idée sur le problème ?

Je pensais peut être que cela pouvait venir de la protections des
feuilles ou du classeur, mais même tout déprotégé l'erreur est toujours
présente ;-)

@+
Bartez


"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub














Avatar
michdenis
Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr, Wk As Workbook
Dim Nom As String, NouveauNom As String

Application.EnableEvents = False
Set Wk = ActiveWorkbook
With Wk
Nb = .Worksheets.Count
For Each Nom_à_Définir In .Sheets(Nb).Names
Nom = Split(.Names(Nom_à_Définir.Name).Name, "!")(1)
Adr = Range(.Names(Nom_à_Définir.Name).Name).Address
For Each Sh In .Worksheets
If Sh.Name <> .Sheets(Nb).Name Then
With Sh
NouveauNom = "'" & .Name & "'!" & Nom
.Range("'" & .Name & "'!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Wk.Sheets(Nb).Range _
(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
End If
Next
Next
End With
Application.EnableEvents = True

End Sub








"Bartez" a écrit dans le message de news:
Ok, j'ai trouvé :)

voici comment j'ai modifié les 2 lignes de code :

NouveauNom = "'" & .Name & "'" & "!" & Nom
.Range("'" & .Name & "'" & "!" & Adr).Name = NouveauNom

Cette fois, avec cette modification, ça fonctionne même avec mon classeur et
mes feuilles renommées.

Merci Michdenis, ton code est bien plus propre que le mien à l'origine.
Par contre pour la vitesse, ça ne m'a pas accéléré les choses.
Une boucle reste une boucle et il faut autant le même temps dans un sens
comme dans l'autre pour lire et écrire les 289 Noms contenus sur ma feuille.
Tanpis.

Ce qui aurrait été bien c'est de prendre comme pour la copies de cellules
(plage) tous les noms d'un coup, changer seulement l'origine de la feuille
"Feuil2!Nom1" devriendrait "Feuil1!Nom1" et de tout coller dans la Feuil1 en
évitant les boucles.

En tout cas, Merci encore de ton aide
@+
Bartez

"Bartez" a écrit dans le message de news:

Je viens de trouver pourquoi ça bloque.

Dans mon classeur, les feuilles sont nommées sous cette forme :
Modèle17(4-2006)

si je change et que je les nomment de façon standard :
Feuil4(Feuil4)

dans ce cas, tout fonctionne

Existe-il une modification à apporter au code pour qu'il puisse travailler
avec correctement avec le nom que j'ai affecté aux feuilles du classeur ?

@+
Bartez

"Bartez" a écrit dans le message de news:

Bonjour Michdenis,

Je viens de tester le code que tu as retouché et curieusement, alors que
sur un classeur standard, ça fonctionne très bien et très rapidement, sur
mon classeur perso, j'obtiens un erreur à la ligne

.Range(.Name & "!" & Adr).Name = NouveauNom

Le débogueur me dit :
"la méthode 'Range' de l'objet '_Worksheet' a échoué"

Je ne comprends pas ce qui peut le déranger alors que cette même ligne ne
pose aucun problème comme je l'ai dit sur un nouveau classeur.

Aurais-tu une idée sur le problème ?

Je pensais peut être que cela pouvait venir de la protections des
feuilles ou du classeur, mais même tout déprotégé l'erreur est toujours
présente ;-)

@+
Bartez


"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub














Avatar
Bartez
Ok, le test sur le nom de la feuille, me fait gagner un peu de temps. 50% si
je n'ai que 2 feuilles et au pire pour le classeur le plus grand (36
feuilles) 1/36em.

@+
Bartez

"michdenis" a écrit dans le message de news:
e$

Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr, Wk As Workbook
Dim Nom As String, NouveauNom As String

Application.EnableEvents = False
Set Wk = ActiveWorkbook
With Wk
Nb = .Worksheets.Count
For Each Nom_à_Définir In .Sheets(Nb).Names
Nom = Split(.Names(Nom_à_Définir.Name).Name, "!")(1)
Adr = Range(.Names(Nom_à_Définir.Name).Name).Address
For Each Sh In .Worksheets
If Sh.Name <> .Sheets(Nb).Name Then
With Sh
NouveauNom = "'" & .Name & "'!" & Nom
.Range("'" & .Name & "'!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Wk.Sheets(Nb).Range _
(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
End If
Next
Next
End With
Application.EnableEvents = True

End Sub








"Bartez" a écrit dans le message de news:

Ok, j'ai trouvé :)

voici comment j'ai modifié les 2 lignes de code :

NouveauNom = "'" & .Name & "'" & "!" & Nom
.Range("'" & .Name & "'" & "!" & Adr).Name = NouveauNom

Cette fois, avec cette modification, ça fonctionne même avec mon classeur
et
mes feuilles renommées.

Merci Michdenis, ton code est bien plus propre que le mien à l'origine.
Par contre pour la vitesse, ça ne m'a pas accéléré les choses.
Une boucle reste une boucle et il faut autant le même temps dans un sens
comme dans l'autre pour lire et écrire les 289 Noms contenus sur ma
feuille.
Tanpis.

Ce qui aurrait été bien c'est de prendre comme pour la copies de cellules
(plage) tous les noms d'un coup, changer seulement l'origine de la feuille
"Feuil2!Nom1" devriendrait "Feuil1!Nom1" et de tout coller dans la Feuil1
en
évitant les boucles.

En tout cas, Merci encore de ton aide
@+
Bartez

"Bartez" a écrit dans le message de news:

Je viens de trouver pourquoi ça bloque.

Dans mon classeur, les feuilles sont nommées sous cette forme :
Modèle17(4-2006)

si je change et que je les nomment de façon standard :
Feuil4(Feuil4)

dans ce cas, tout fonctionne

Existe-il une modification à apporter au code pour qu'il puisse
travailler
avec correctement avec le nom que j'ai affecté aux feuilles du classeur ?

@+
Bartez

"Bartez" a écrit dans le message de news:

Bonjour Michdenis,

Je viens de tester le code que tu as retouché et curieusement, alors que
sur un classeur standard, ça fonctionne très bien et très rapidement,
sur
mon classeur perso, j'obtiens un erreur à la ligne

.Range(.Name & "!" & Adr).Name = NouveauNom

Le débogueur me dit :
"la méthode 'Range' de l'objet '_Worksheet' a échoué"

Je ne comprends pas ce qui peut le déranger alors que cette même ligne
ne
pose aucun problème comme je l'ai dit sur un nouveau classeur.

Aurais-tu une idée sur le problème ?

Je pensais peut être que cela pouvait venir de la protections des
feuilles ou du classeur, mais même tout déprotégé l'erreur est toujours
présente ;-)

@+
Bartez


"michdenis" a écrit dans le message de news:
%

Private Sub Copier_les_Noms_et_leurs_Étiquettes()

Dim Sh As Worksheet, Nb As Integer
Dim Nom_à_Définir As Name, Adr
Dim Nom As String, NouveauNom As String

Nb = Worksheets.Count
For Each Nom_à_Définir In Sheets(Nb).Names
Nom = Split(Nom_à_Définir.Name, "!")(1)
Adr = Range(Nom_à_Définir).Address
For Each Sh In Worksheets
With Sh
NouveauNom = .Name & "!" & Nom
.Range(.Name & "!" & Adr).Name = NouveauNom
With .Range(NouveauNom)
If .Column = 80 Then
.Offset(0, -1).Value = _
Range(Nom_à_Définir.Name).Offset(0, -1).Value
End If
End With
End With
Next
Next

End Sub