Sujet Précédent Sujet Suivant

Excel - VBA

Résolu/Fermé
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 - 11 mai 2010 à 20:50
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 - 17 mai 2010 à 21:23
bonsoir à toutes et tous,

Voilà mon soucis :
Sous excel, j't'utilise un code pour copier d'un "userform" 2 cellules et les coller d'une feuille .... (en gros hein ...) j'aimerais le faire sur plusieurs feuilles (copier les mêmes infos aux mêmes endroits), comment faire .... ??
- feuille de base : effectif_actifs
- copie sur : effectif_amicale, vacances

Voici ce code : 
Sub nouvelle(nom, grade) 'insère une nouvelle feuille de donnée

Sheets("effectif_actifs").Activate

nouvnom = Replace(nom, " ", "_")

On Error GoTo er1
n = StrConv(Split(nom, " ")(0), vbUpperCase) & " " & StrConv(Mid(Split(nom, " ")(1), 1, 1), vbUpperCase) & Mid(Split(nom, " ")(1), 2)

g = StrConv(grade, vbUpperCase)

Sheets("effectif_actifs").Rows("5:5").Select
    Selection.Insert Shift:=xlDown
Sheets("effectif_actifs").Range("B5").Value = n
Sheets("effectif_actifs").Range("C5").Value = g
Sheets("effectif_actifs").Range("B5:L5").Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
    Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
    
For cal = 4 To Sheets("effectif_actifs").Range("A10000").End(xlUp).Row


Next cal

c = cal - 1

Sheets("effectif_actifs").Range("B5:L5" & c).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'For i = 4 To Sheets("effectif_actifs").Range("A10000").End(xlUp).Row

'If Cells(i, 1).Value = n Then Exit For

'Next i

Next 'à remplacer par ??????

Sheets("effectif_amicale").Rows("5:5").Select
    Selection.Insert Shift:=xlDown
Sheets("effectif_amicale").Range("B5").Value = n
Sheets("effectif_amicale").Range("C5").Value = g
Sheets("effectif_amicale").Range("B5:L5").Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
    Selection.Borders(xlInsideVertical).LineStyle = xlContinuous

For cal = 4 To Sheets("effectif_amicale").Range("A10000").End(xlUp).Row

Next cal

c = cal - 1

Sheets("effectif_amicale").Range("B5:L5" & c).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal


'For i = 4 To Sheets("effectif_amicale").Range("A10000").End(xlUp).Row

'If Cells(i, 1).Value = n Then Exit For

'Next i



'Sheets("vierge").Cells.Copy
'Sheets.Add
'ActiveSheet.Name = nouvnom
'ActiveSheet.Paste
'ActiveSheet.Range("A5").Value = n
'ActiveSheet.Range("B5").Value = g
'ActiveWindow.Zoom = 50

'If i = Sheets.Count + 1 Then
'ActiveSheet.Move after:=Sheets(Sheets.Count)
'Else
'ActiveSheet.Move before:=Sheets(i)
'End If


Unload UserForm1

Exit Sub

er1:

MsgBox "Format Non Valide, Veuillez entrer un Nom, Espace et Prénom", vbCritical
Exit Sub

End Sub


ça doit être simple quand on connait ... Moi je récupère des bouts de code par ci par là, et j'adapte ....

Merci de votre aide !

Joko

11 réponses

Réponse 1 / 11
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 289
11 mai 2010 à 22:21
Bonsoir,
Tu peux utiliser un code du type : 

Sub nouvelle(nom, grade) 
Dim feuille As Worksheet 
For Each feuille In Worksheets(Array("effectif_actifs", "effectif_amicale","vacances")) 
    ' Ton code de copie des valeurs
Next feuille 
End Sub

@+
1
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 289
11 mai 2010 à 22:28
Je n'ai pas regardé ton code en détail, mais tu gagneras en rapidité en remplaçant : 
Sheets("effectif_actifs").Rows("5:5").Select
Selection.Insert Shift:=xlDown
Sheets("effectif_actifs").Range("B5").Value = n
Sheets("effectif_actifs").Range("C5").Value = g
Sheets("effectif_actifs").Range("B5:L5").Select
Selection.Interior.ColorIndex = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous

Par : 
With Sheets("effectif_actifs")
    .Rows("5:5").Insert Shift:=xlDown
    .Range("B5").Value = n
    .Range("C5").Value = g
End With
With Sheets("effectif_actifs").Range("B5:L5")
    .Interior.ColorIndex = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
End With
0
Réponse 2 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
11 mai 2010 à 22:38
je ne comprends pas comment utiliser ce code en fait ....
Je comprends que le code que je devrais coller agirait sur plusieurs feuilles (effectif_actifs, effectif_amicale et vacances), mais je ne sais pas comment mettre le code qui va bien dessus ...
0
Réponse 3 / 11
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 289
11 mai 2010 à 23:04 
Sub nouvelle(nom As String, grade As String) 'insère une nouvelle feuille de donnée
'
' Déclaration des variables
Dim nom_2 As String
Dim grade_2 As String
Dim feuille As Worksheet
'
' Vérification des nom et grade
On Error GoTo er1
nom_2 = StrConv(Split(nom, " ")(0), vbUpperCase) & " " & _
  StrConv(Mid(Split(nom, " ")(1), 1, 1), vbUpperCase) & _
  Mid(Split(nom, " ")(1), 2)
grade_2 = StrConv(grade, vbUpperCase)

For Each feuille In Worksheets(Array("effectif_actifs", "effectif_amicale", "vacances"))
  feuille.Rows("5:5").Insert Shift:=xlDown
  feuille.Range("B5").Value = nom_2
  feuille.Range("C5").Value = grade_2
  With feuille.Range("B5:L5")
    .Interior.ColorIndex = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
  End With
  For cal = 4 To feuille.Range("A10000").End(xlUp).Row
  '
  Next cal
  feuille.Range("B5:L5" & (cal - 1)).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Next feuille

Unload UserForm1
Exit Sub

er1:
MsgBox "Format Non Valide, Veuillez entrer un Nom, Espace et Prénom", vbCritical

End Sub

Je t'ai laissé ta formule pour extraire nom_2 mais elle me parait bizarre
0
Réponse 4 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
11 mai 2010 à 23:31
J'ai modifier le truc grace à l'enregistreur de macro et le premier code donné plus haut ... voici ce que ça donne (j'ai encore une erreur à la fin ou c'est en gras !!!) : 
Sub nouvelle(nom, grade) 'insère une nouvelle feuille de donnée

Sheets("effectif_actifs").Activate

nouvnom = Replace(nom, " ", "_")

On Error GoTo er1

n = StrConv(Split(nom, " ")(0), vbUpperCase) & " " & StrConv(Mid(Split(nom, " ")(1), 1, 1), vbUpperCase) & Mid(Split(nom, " ")(1), 2)

g = StrConv(grade, vbUpperCase)

Sheets(Array("effectif_actifs", "effectif_amicale", "vacances")).Select
    Rows("5:5").Select
    Selection.Insert Shift:=xlDown
    Sheets("effectif_actifs").Activate
Sheets("effectif_actifs").Range("B5").Value = n
Sheets("effectif_actifs").Range("C5").Value = g
Sheets("effectif_amicale").Range("B5").Value = n
Sheets("effectif_amicale").Range("C5").Value = g
Sheets("vacances").Range("B5").Value = n
Sheets("vacances").Range("C5").Value = g

Sheets(Array("effectif_actifs", "effectif_amicale")).Select
    Range("B5:L5").Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
    Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Sheets("vacances").Select
    Range("B5:DF5").Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
    Selection.Borders(xlInsideVertical).LineStyle = xlContinuous

Sheets("effectif_actifs").Activate
    
For cal = 4 To Sheets("effectif_actifs").Range("A10000").End(xlUp).Row

Next cal

c = cal - 1

Sheets("effectif_actifs").Range("B5:L5" & c).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
Sheets("effectif_amicale").Activate
    
For cal = 4 To Sheets("effectif_amicale").Range("A10000").End(xlUp).Row

Next cal

c = cal - 1

Sheets("effectif_amicale").Range("B5:L5" & c).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("vacances").Activate
    
For cal = 4 To Sheets("vacances").Range("A10000").End(xlUp).Row

Next cal

c = cal - 1

Sheets("vacances").Range("B5:DF5" & c).Sort Key1:=Range("B5"), Order1:=xlAscending, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal




Unload UserForm1

Exit Sub

er1:

MsgBox "Format Non Valide, Veuillez entrer un Nom, Espace et Prénom", vbCritical
Exit Sub

End Sub
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
11 mai 2010 à 23:41
en fait, mon code marche impec grace à vos idées et codes, j'ai pu "comprendre" ce que je faisais et là où ça plantait ... !!!
pour info, ça plantait dans la dernière feuille car j'avais des cellules fusionnées et donc ça ne prend pas le classement A-Z ...... dommage ! (y'a pas moyen de contourner ce problème en disant "sauf cette ligne" ...???).

Sinon petit soucis .... Avez vous une idée pour mettre devant les noms dans la colonne A le nombre de personne qui rentre ........ 1,2,3,4,5,........... automatiquement jusqu'au dernier personnel ..??

merci !!!!!!!!
0
Réponse 6 / 11
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 289
12 mai 2010 à 14:12
Bonjour,
Juste une remarque, je pensais que tu ne voulais pas mettre tout le code mais j'ai un doute puisque tu le répète : 
For cal = 4 To Sheets("vacances").Range("A10000").End(xlUp).Row
Next cal
c = cal - 1

Sert juste à ralentir ta macro, tu peux remplacer par : 
c= Sheets("vacances").Range("A10000").End(xlUp).Row - 1


Sinon, une autre erreur est : 
Sheets("vacances").Range("B5:DF5" & c).

à remplacer par : 
Sheets("vacances").Range("B5:DF" & c).


Dans mon poste précédent, je te parlais de formule bizarre pour mettre en forme le nom, avec le recul, je me rend compte que ce n'est pas explicit : elle fonctionne certainement (je n'ai jamais utilisé cette syntaxe, j'utilise plutôt InStr, Left, Right)pour Paul Dupond mais je ne sais pas si elle te renvoie ce que tu souhaite pour les noms composé. J'utiliserais plutôt deux champs dans l'Userform un Nom et un Prénom.

Pour ta question, par exemple : 
Dim compteur As Long
compteur = 0
While Range("B1").Offset(compteur,0).Value <>""
   Range("A1").Offset(compteur,0).Value = compteur + 1
Wend

@+
0
Réponse 7 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
12 mai 2010 à 21:54
merci des codes envoyés, ils sont copiés et mis au chaud pour réutilisable ... sinon un ami au boulot qui gère aussi m'a fait un truc vite fait qui marche aussi ... : 
Sheets("effectif_amicale").Activate

Set IP = ActiveWorkbook.Sheets("effectif_amicale")

For a = 5 To 1000

If IP.Cells(a, 2) <> "" Then
    IP.Cells(a, 1) = a - 4

End If


merci pour tes modifs, ça marche niquel !

autre question ?? ;)

Comment faire via un bouton "supprimer un nom" supprimer une ligne où se trouve des informations (nom prénom d'une liste) de la colonne B ...........??!!

encore merci !
0
Réponse 8 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
14 mai 2010 à 23:10
bonsoir !

pour la question du dessus, je vais trouvé ...

j'ai un autre soucis ... : faire la somme de plusieurs cellules, d'une cellule connue de départ, à l'arrivée inconnu, jusque là pour "select" c'est sans soucis, mais pour en faire la somme ... je bute ... :(
En voici le code : 
Sub moyage()
Sheets("effectif_amicale").Activate
c = Sheets("effectif_amicale").Range("A1000").End(xlUp).Row
Sheets("effectif_amicale").Range("L5:L" & c).Select
    ActiveCell.FormulaR1C1 = "=SUM()"
End Sub


merci
0
Réponse 9 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
14 mai 2010 à 23:59
re :

J'ai trouvé en partie, mais je galère encore :(

j'arrive à afficher dans une msgbox la somme 
Sub moyage()
Sheets("effectif_amicale").Activate
c = Sheets("effectif_amicale").Range("A1000").End(xlUp).Row
'MsgBox Worksheets("effectif_amicale").Range("L5:L" & c)
MsgBox Application.WorksheetFunction.Sum(Range("L5:L" & c)) / c
'    ActiveCell.FormulaR1C1 = "=SUM()"
End Sub


Comment pourrais je faire pour remplacer l'affichage par la somme divisé par le nombre de ligne sélectionnée .... ???

merci !
0
Réponse 10 / 11
J0K0 Messages postés 163 Date d'inscription lundi 7 mai 2007 Statut Membre Dernière intervention 19 juillet 2019 17
15 mai 2010 à 00:24
bon bon bon ... avec les heures qui défilent j'arrive très doucement à avancer ... j'arrive à afficher dans une cellule voulue le total : 
Sub moyage()
Sheets("effectif_amicale").Activate
c = Sheets("effectif_amicale").Range("A1000").End(xlUp).Row
Sheets("effectif_amicale").Range("L25") = WorksheetFunction.Sum(Range("L5:L" & c))
End Sub


Reste plus qu'à trouver comment diviser cette somme par le nombre de cellules sélectionnées .....

UNE IDEE SVP ???
0
Réponse 11 / 11
Gord21 Messages postés 918 Date d'inscription samedi 21 novembre 2009 Statut Membre Dernière intervention 20 mars 2013 289
Modifié par Gord21 le 17/05/2010 à 21:24
Bonsoir,
Après un grand week-end, je te répond enfin :-)

Post 8 :
Pour supprimer un nom, tu peux faire un userform avec des listes de choix sur les différents paramètres à rechercher, un bouton supprimer et un annuler. Ensuite, tu parcours les lignes de ton classeur à la recherche des critères. Du genre : 
i=0 
While Range("B1").Offset(i,0).Value <> "" 
   If Range("B1").Offset(i,0).Value =critere_recherche Then 
      Rows(i).Delete Shift:=xlUp 
   Else 
      i = i + 1 
   End If 
Wend

Post 11 : 

Sub moyage() 
Sheets("effectif_amicale").Activate 
c = Sheets("effectif_amicale").Range("A1000").End(xlUp).Row 
moyenne = WorksheetFunction.Sum(Range("L5:L" & c))/WorksheetFunction.CountA(Range("L5:L" & c)) 
End Sub


@+
Expérience: nom dont les hommes baptisent leurs erreurs.
Oscar Wilde
0