"copie" de cellules

delfalle · 23 Juin 2015

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

djidji59430 · 23 Juin 2015

Re : "copie" de cellules

Bonjour,

=recherchev(departement;base;2;0)

Le fichier avec la correspondance Département<=>Ville académie est fortement demandé sous la forme département|académie
Cdmt

job75 · 23 Juin 2015

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+

delfalle · 23 Juin 2015

Re : "copie" de cellules

djidji59430 à dit:
Bonjour,

=recherchev(departement;base;2;0)

Le fichier avec la correspondance Département<=>Ville académie est fortement demandé sous la forme département|académie
Cdmt

Est-ce que ce type de fichiers correspond a votre demande ?

delfalle · 23 Juin 2015

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+

job75 · 23 Juin 2015

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+

ROGER2327 · 23 Juin 2015

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

job75 · 23 Juin 2015

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 ...

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+

job75 · 23 Juin 2015

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+

job75 · 23 Juin 2015

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+

job75 · 24 Juin 2015

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.

job75 · 24 Juin 2015

Re : "copie" de cellules

Re,

Sur Win 8 - Excel 2013 la macro s'exécute en 0,30 seconde sur un tableau de 10000 lignes.

A+

delfalle · 24 Juin 2015

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

"copie" de cellules

delfalle

Guest

djidji59430

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

delfalle

Guest

Pièces jointes

delfalle

Guest

Pièces jointes

job75

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

delfalle

Guest

Discussions similaires

"copie" de cellules

delfalle

Guest

XLDnaute Barbatruc

XLDnaute Barbatruc

delfalle

Guest

Pièces jointes

delfalle

Guest

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

delfalle

Guest

Discussions similaires

Privacy & Transparency

Privacy & Transparency