"copie" de cellules

D

delfalle

XLDnaute Nouveau
Bonjour,

voici mon problème :

dans mes cellules de la colonne b je vais saisir des départements (75, 93, 91 ...)
je souhaiterais, dans les cellules correspondantes dans la colonne c, obtenir l'écriture directe de l'académie correspondante ( exemple si je saisis 75 en b2 j’obtiens Paris en c2, si je saisis 93 (ou 94 ou77) en b3 j'obtiens créteil en C3, et si je saisis 91( ou 92 ou 95 ou 78) en b4 j'obtiens Versailles en c4...)

J'espère avoir été suffisamment claire...

Merci d'avance pour votre aide.

Delfalle
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Bonjour delfalle, bienvenue sur XLD,

Placez cette macro dans le code de la feuille (clic droit sur l'onglet et visualiser le code) :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, v As Variant
Set r = Intersect(Target, Range("B2:B" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Dim a(1 To 1000) As String
'---tableau de correspondance à compléter---
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
On Error Resume Next 's'il n'y a pas de correspondance
For Each r In r 'en cas d'entrées multiples
  r(, 2) = ""
  r(, 2) = a(r)
Next
End Sub
Elle s'exécute quand on entre une donnée en colonne B à partir de B2.

Edit : salut djidji59430.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
D

delfalle

XLDnaute Nouveau
Re : "copie" de cellules

Bjr job75,

Merci bcp pour votre réponse très rapide.
Néanmoins j'ai oublié de préciser que la colonne B serait remplie par STXT de la colonne A voir fichier ci-joint...
Donc je n'arrive pas à utiliser votre code par macro ainsi .
Je ne suis tjs pas sûre d'être très claire ...

Merci bcp pour votre patience

Delfalle


job75 à dit:
Bonjour delfalle, bienvenue sur XLD,

Placez cette macro dans le code de la feuille (clic droit sur l'onglet et visualiser le code) :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, v As Variant
Set r = Intersect(Target, Range("B2:B" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Dim a(1 To 1000) As String
'---tableau de correspondance à compléter---
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
On Error Resume Next 's'il n'y a pas de correspondance
For Each r In r 'en cas d'entrées multiples
  r(, 2) = ""
  r(, 2) = a(r)
Next
End Sub
Elle s'exécute quand on entre une donnée en colonne B à partir de B2.

Edit : salut djidji59430.

A+
Cliquez pour agrandir...
 

Pièces jointes

  • essai1.xlsx
    10.1 KB · Affichages: 29
  • essai1.xlsx
    10.1 KB · Affichages: 37
  • essai1.xlsx
    10.1 KB · Affichages: 41
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Re,

Si l'on veut pouvoir entrer les départements 2A et 2B de la Corse, on utilisera :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, v As Variant
Set r = Intersect(Target, Range("B2:B" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Dim a(1 To 1000) As String
'---tableau de correspondance à compléter---
a(20) = "Corse"
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
On Error Resume Next 's'il n'y a pas de correspondance
For Each r In r 'en cas d'entrées multiples
  r(, 2) = ""
  r(, 2) = a(r)
  If r = "2A" Or r = "2B" Then r(, 2) = a(20)
Next
End Sub
A+
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : "copie" de cellules

Bonjour à tous.


Avec une formule.​


ℝOGER2327
#7938

Lundi 9 Gidouille 142 (Sainte Outre, psychiatre - fête Suprême Quarte)
5 Messidor An CCXXIII, 6,2761h - mulet
2015-W26-2T15:03:45Z
 

Pièces jointes

  • Académie-Départements.xlsx
    10.3 KB · Affichages: 17
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Re,

delfalle à dit:
Néanmoins j'ai oublié de préciser que la colonne B serait remplie par STXT de la colonne A voir fichier ci-joint...
Donc je n'arrive pas à utiliser votre code par macro ainsi .
Je ne suis tjs pas sûre d'être très claire ...
Cliquez pour agrandir...

C'est très clair, alors on peut utiliser l'évènement Calculate :

Code: 
Private Sub Worksheet_Calculate()
Dim r As Range
Dim a(1 To 1000) As String
'---tableau de correspondance à compléter---
a(20) = "Corse"
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 's'il n'y a pas de correspondance
Range("C2:C" & Rows.Count) = "" 'RAZ
For Each r In [B:B].SpecialCells(xlCellTypeFormulas)
  r(, 2) = a(r)
  If r = "2A" Or r = "2B" Then r(, 2) = a(20)
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Re, bonjour Roger, je ne vous avais pas salué,

Avec des tableaux VBA c'est beaucoup plus rapide s'il y a beaucoup de lignes :

Code: 
Private Sub Worksheet_Calculate()
Dim a$(1 To 1000), t, rest$(), i&
'---tableau de correspondance à compléter---
a(20) = "Corse"
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
t = [A1].CurrentRegion.Resize(, 2)
ReDim rest(1 To UBound(t), 1 To 1)
On Error Resume Next 's'il n'y a pas de correspondance
For i = 1 To UBound(t) - 1
  rest(i, 1) = a(t(i + 1, 2))
  If t(i + 1, 2) = "2A" Or t(i + 1, 2) = "2B" Then rest(i, 1) = a(20)
Next
Application.EnableEvents = False 'désactive les évènements
[C2].Resize(UBound(t)) = rest
Application.EnableEvents = True 'réactive les évènements
End Sub
A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Re,

Cela dit puisqu'on utilise VBA les formules en colonne B sont inutiles :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$(1 To 1000), t, n&, i&
'---tableau de correspondance à compléter---
a(20) = "Corse"
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
'---etc---
t = Me.UsedRange.Resize(, 4)
n = 1
On Error Resume Next 's'il n'y a pas de correspondance
For i = 2 To UBound(t)
  If t(i, 1) <> "" Then
    n = n + 1
    t(n, 1) = t(i, 1)
    t(n, 2) = Mid(t(n, 1), 2, 2)
    t(n, 3) = ""
    t(n, 3) = a(t(n, 2))
    If t(n, 2) = "2A" Or t(n, 2) = "2B" Then t(n, 3) = a(20)
    t(n, 4) = ""
    If t(n, 3) <> "" Then t(n, 4) = "ce." & t(n, 1) & "@ac-" & t(n, 3) & ".fr"
    '---pour créer des liens hypertextes (facultatif)---
    If t(n, 3) <> "" Then t(n, 4) = "=HYPERLINK(""" & t(n, 4) & """)"
  End If
Next
Application.EnableEvents = False 'désactive les évènements
[A:A].NumberFormat = "@"
[A1].Resize(n, 4) = t
Range("A" & n + 1 & ":D" & Rows.Count).Delete xlUp
Application.EnableEvents = True 'réactive les évènements
End Sub
J'entre une formule en colonne D pour créer les liens hypertextes (facultatif).

Notez que si l'on efface une cellule en colonne A le tableau se décale vers le haut.

Bonne soirée et A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : "copie" de cellules

Bonjour delfalle, le forum,

On notera que les départements de la Métropole ont 2 chiffres, le numéro en colonne A commence par 0.

Pour les DOM-TOM les départements ont 3 chiffres, le numéro en colonne A doit commencer par 9.

Donc modifier le calcul de t(n, 2) :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$(1 To 1000), t, n&, i&
'---tableau de correspondance à compléter---
a(1) = "Lyon"
a(2) = "Amiens"
a(3) = "Clermont"
a(20) = "Corse"
a(75) = "Paris"
a(77) = "Créteil"
a(78) = "Versailles"
a(91) = "Versailles"
a(92) = "Versailles"
a(93) = "Créteil"
a(94) = "Créteil"
a(95) = "Versailles"
a(971) = "Guadeloupe"
a(972) = "Martinique"
a(973) = "Guyane"
a(974) = "Réunion"
'---etc---
t = Me.UsedRange.Resize(, 4)
n = 1
On Error Resume Next 's'il n'y a pas de correspondance
For i = 2 To UBound(t)
  If t(i, 1) <> "" Then
    n = n + 1
    t(n, 1) = t(i, 1)
    t(n, 2) = IIf(Left(t(n, 1), 1) = 0, Mid(t(n, 1), 2, 2), Left(t(n, 1), 3))
    t(n, 3) = ""
    t(n, 3) = a(t(n, 2))
    If t(n, 2) = "2A" Or t(n, 2) = "2B" Then t(n, 3) = a(20)
    t(n, 4) = ""
    If t(n, 3) <> "" Then t(n, 4) = "ce." & t(n, 1) & "@ac-" & t(n, 3) & ".fr"
    t(n, 4) = LCase(Replace(t(n, 4), "é", "e"))
    '---pour créer des liens hypertextes (facultatif)---
    If t(n, 3) <> "" Then t(n, 4) = "=HYPERLINK(""" & t(n, 4) & """)"
  End If
Next
Application.EnableEvents = False 'désactive les évènements
[A:A].NumberFormat = "@" 'format Texte
[B:B].NumberFormat = "00" 'affiche au moins 2 chiffres
[A1].Resize(n, 4) = t
Range("A" & n + 1 & ":D" & Rows.Count).Delete xlUp
Application.EnableEvents = True 'réactive les évènements
End Sub
Edit 1 : je mets des minuscules avec LCase et j'enlève l'accent en colonne D.

Edit 2 : je mets la colonne B au format nombre "00" pour afficher au moins 2 chiffres.

Bonne journée.
 
Dernière édition:
Vote positif 0 Vote négatif
D

delfalle

XLDnaute Nouveau
Re : "copie" de cellules

Bjr à tous,

merci bcp pour vos messages et réponses si rapides,
je travaille demain et je ferai donc les essais demain.

Merci encore pour votre aide et si nécessaire je vous recontacte demain :)

bonne journée

@ bientôt

Delfalle
 
Vote positif 0 Vote négatif

Discussions similaires

chilo27
  • Question
Autres Simplifier une macro
Réponses
1
Affichages
256
fanch55
fanch55
C
  • Question
Autres Apprentissage d'une langue : adapter la couleur des cellules en fonction du pourcentage d'évaluation
Réponses
2
Affichages
246
crocrocro
C
Usine à gaz
  • Résolu(e)
XL 2021 affectation et classement de mes appels selon contenu des cellules en colonnes J ou L ou M
2 3
Réponses
30
Affichages
936
Usine à gaz
Usine à gaz
F
  • Résolu(e)
XL 2021 Figer une sélection de cellules quand on se déplace dans la feuille
Réponses
4
Affichages
270
fanou06
F
W
  • Question
XL 2016 Coloration ou pas des cellules voisines de la colonne B
Réponses
2
Affichages
207
Webperegrino
W
Darkopsix
  • Résolu(e)
XL 2021 Récupérer des données de fichiers dons les noms sont renseignés dans des cellules
Réponses
2
Affichages
402
Darkopsix
Darkopsix
M
  • Résolu(e)
XL 2016 #REF ! et nom de cellule existant sur cellules nommées
2
Réponses
16
Affichages
487
Mak_tarmak
M
X
  • Question
XL pour MAC Colorier une cellule dans les lignes impaires de mon tableau, dont la valeur est > à 150
2
Réponses
15
Affichages
722
TooFatBoy
TooFatBoy
T
  • Résolu(e)
XL 2010 Formule - Si 2 cellules non vides sur une plage de cellules
Réponses
5
Affichages
449
Titi456
T
F
  • Question
XL 2016 Retrouver base de données à partir de cellules contenant une rechercheV
Réponses
3
Affichages
236
WTF
WTF

Membres actuellement en ligne

8 membres et 126 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 111
Messages
2 085 403
Membres
102 883
dernier inscrit
jameseyz