Macro pour copier automatiquement une matricule

[anasimo]

Bonjour

cherche mac pour copier 1 matricule (j'ai déja testé la fonction IF, trop long)...j'explique

Dans la cellule D16 de la feuille "module" j'ai 1 matricule
je veux que cette matricule soit copiée dans la colonne B des feuilles BD1 BD2 et BD3 à chaque qu'il y a des données dans ces colonnes

feuilles BD1 BD2 et BD3

 

[xUpsilon]

Salut jborm, le fil,
Si l'entité venait à être un nombre, la condition ESTTEXTE serait fausse, donc on ne peut pas appliquer ça. On peut appliquer si ESTVIDE = Faux en revanche.
@anasimo comment ça quand tu ajoutes d'autres données ?

Bonne continuation

 

[jborm2b]

Salut Anasimo tu as qu'à mettre sous forme de tableau. A chaque fois que tu rajoutes une ligne les formules restent.
Upsilon a raison utilise estvide, c'est plus adapté que esttexte.

 

[anasimo]

Salut jborm, le fil,
Si l'entité venait à être un nombre, la condition ESTTEXTE serait fausse, donc on ne peut pas appliquer ça. On peut appliquer si ESTVIDE = Faux en revanche.
@anasimo comment ça quand tu ajoutes d'autres données ?

Bonne continuation

oui quand j'alimente le tableau par d'autre données.
La colonne D recevra que des données numériques

 

[anasimo]

Voila je vais mettre un fichier qui comprend une macro qui marche bien et répond à mes attentes (j'ai récupéré un bout développé par Dranreb) ...et je veux la corriger et l'adapter à mon fichier (supprimer les codes en trop ...) et mettre les noms de feuilles (modules, BD1,2et3) au lieu de Feui1 et Feuil2

le code déja utilisé....je sais qu'il faut le nettoyer car y a des éléments de trop

Sub générer()
   Dim CelADéb As Range, NbLig As Long
   
   Set CelADéb = Feuil2.[A1000000].End(xlUp).Offset(1)
   NbLig = Feuil2.[D1000000].End(xlUp).Row + 1 - CelADéb.Row
   
   
   If NbLig > 0 Then
   With CelADéb.Resize(NbLig)
     .Formula = "=""" & Feuil1.[D16].Value _
           & """&TEXT(ROW()-" & CelADéb.Row - 1 & ","""")"
      
      .Value = .Value: End With

   
      End If
         
    End Sub

 

[job75]

Bonjour anasimo, xUpsilon, jborm2b,

Voyez le fichier joint et cette macro dans le code de ThisWorkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim matricule As Range, w As Worksheet
Set matricule = Sheets("module").[D16] 'cellule à adapter au besoin
If Sh.Name = matricule.Parent.Name Then
    If Intersect(Target, matricule) Is Nothing Then Exit Sub
    For Each w In Worksheets
        Workbook_SheetChange w, w.Cells(1) 'déclenche la macro
    Next
ElseIf UCase(Sh.Name) Like "BD#*" Then
    Application.EnableEvents = False 'désactive les évènements
    With Sh.Cells(1).CurrentRegion
        If .Rows.Count > 1 Then .Cells(2, 2).Resize(.Rows.Count - 1) = matricule 'remplissage de la 2ème colonne
    End With
    Application.EnableEvents = True 'réactive les évènements
End If
End Sub

La macro se déclenche quand on modifie une cellule quelconque dans une des feuilles.

A+

 

[anasimo]

Bonjour anasimo, xUpsilon, jborm2b,

Voyez le fichier joint et cette macro dans le code de ThisWorkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim matricule As Range, w As Worksheet
Set matricule = Sheets("module").[D16] 'cellule à adapter au besoin
If Sh.Name = matricule.Parent.Name Then
    If Intersect(Target, matricule) Is Nothing Then Exit Sub
    For Each w In Worksheets
        Workbook_SheetChange w, w.Cells(1) 'déclenche la macro
    Next
ElseIf UCase(Sh.Name) Like "BD#*" Then
    Application.EnableEvents = False 'désactive les évènements
    With Sh.Cells(1).CurrentRegion
        If .Rows.Count > 1 Then .Cells(2, 2).Resize(.Rows.Count - 1) = matricule 'remplissage de la 2ème colonne
    End With
    Application.EnableEvents = True 'réactive les évènements
End If
End Sub

La macro se déclenche quand on modifie une cellule quelconque dans une des feuilles.

A+

oui ça marche.....mais 2 soucis
- si on efface les données d'une ligne le code ne s'efface pas.
- Si je change le code il remplace celui déja saisi. (ça posera problème de traçabilité)

 

[job75]

Il ne faut pas effacer une ligne mais la supprimer entièrement.

Pour le reste voyez ce fichier (2) et la nouvelle macro :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim matricule As Range, w As Worksheet
Set matricule = Sheets("module").[D16] 'cellule à adapter au besoin
If Sh.Name = matricule.Parent.Name Then
    If Intersect(Target, matricule) Is Nothing Then Exit Sub
    For Each w In Worksheets
        Workbook_SheetChange w, w.Cells(1) 'déclenche la macro
    Next
ElseIf UCase(Sh.Name) Like "BD#*" Then
    Application.EnableEvents = False 'désactive les évènements
    With Sh.Cells(1).CurrentRegion.Columns(2)
        If Application.CountBlank(.Cells) Then .SpecialCells(xlCellTypeBlanks) = matricule 'remplit les cellules vides de la 2ème colonne
    End With
    Application.EnableEvents = True 'réactive les évènements
End If
End Sub

 

[anasimo]

vous êtes presque 🙂

pourquoi on ne peut l'effacer une fois généré.....il supprimer cellule par cellule

 

[job75]

Cette question n'a pa pas de sens, vous voulez remplir la colonne B oui ou non ???

 

[anasimo]

bon ça dérange pas ce petit soucis....Merci beaucoup JOB pour votre aide et je vous suis très reconnaissant

 

[job75]

Maintenant si vous préférez utiliser des boutons c'est très simple :

Sub MAJ()
On Error Resume Next 'si aucune SpecialCell
If UCase(ActiveSheet.Name) Like "BD#*" Then [A1].CurrentRegion.Columns(2).SpecialCells(xlCellTypeBlanks) = Sheets("module").[D16]
End Sub