Macro pour copier automatiquement une matricule

anasimo

XLDnaute Occasionnel
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
Capture29.JPG
 

Pièces jointes

  • copier code.xlsx
    17.9 KB · Affichages: 14

anasimo

XLDnaute Occasionnel
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
VB:
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
 

Pièces jointes

  • exemple code.xlsm
    20.1 KB · Affichages: 4
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour anasimo, xUpsilon, jborm2b,

Voyez le fichier joint et cette macro dans le code de ThisWorkbook :
VB:
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+
 

Pièces jointes

  • copier code(1).xlsm
    27.2 KB · Affichages: 6
Dernière édition:

anasimo

XLDnaute Occasionnel
Bonjour anasimo, xUpsilon, jborm2b,

Voyez le fichier joint et cette macro dans le code de ThisWorkbook :
VB:
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

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

Pour le reste voyez ce fichier (2) et la nouvelle macro :
VB:
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
 

Pièces jointes

  • copier code(2).xlsm
    26.4 KB · Affichages: 5

job75

XLDnaute Barbatruc
Maintenant si vous préférez utiliser des boutons c'est très simple :
VB:
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
 

Pièces jointes

  • copier code(3).xlsm
    28.2 KB · Affichages: 7

Discussions similaires

Réponses
7
Affichages
159

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG