Automatiser les actions [Résolu]

Messages postés
4
Date d'inscription
vendredi 17 juin 2011
Dernière intervention
22 juin 2011
- - Dernière réponse : cs_Vincent58
Messages postés
4
Date d'inscription
vendredi 17 juin 2011
Dernière intervention
22 juin 2011
- 22 juin 2011 à 18:40
Bonjour à tous,

Tout nouveau venu sur le forum, j'ai déjà pu trouver pas mal d'informations grâce a vous et je vous en remercie! Aujourd'hui je viens vous voir car fraîchement débutant en vba sur excel 2007, je dois constituer une base de donnée concurrentielle qui dois être la plus claire possible pour ceux qui devront l’utiliser.
A cet effet, j’aurais quelques questions à vous poser car mes codes ne marchent pas, ou quand ils marchent, sont tellement rafistolés qu’ils pèteront au moindre écart… Je vous remercie par avance car je sais que cela ne se fait pas vraiment de vous demander de faire le travail à ma place, mais après tout, cela me permet d’apprendre tout autant.

Je m’explique. J’ai une base concurrentielle d’environs 35 feuilles. Ce que je veux obtenir, c’est une base où les premières feuilles sont fixes, et les suivantes sont du nom des concurrents, et où je puisse ajouter des concurrents. J’ai ainsi arrangé manuellement : « 1. Instructions », « 2. Overview », etc puis les concurrents « A », « B », « C », etc.
Jusqu'à présent, ma macro « Add_competitor » crée une nouvelle feuille à la suite de « 4. Example » avec un msgbox demandant de mettre le nom du concurrent :
Sub Add_competitor()
Sheets("4.Example").Select
Sheets("4.Example").Copy Before:=Sheets(6)
Sheets("4.Example (2)").Select
Sheets("4.Example (2)").Name = "Name of new competitor"
MsgBox ("Please input the name of the new competitor on the sheet")
Range("B3").Select
End Sub

Ce que je voudrais, c’est à vrai dire que la macro fasse cela :
1. Lors de la création de la nouvelle feuille, la msgbox me demande de nommer la cellule B3 et que je puisse taper le nom dans la msgbox directement (on l’appelera NOM ).
2. Le nom sera toujours situé en cellule B3. Il faudrait que le NOM en B3 soit aussi le même pour le nom de la feuille (ce que je n’ai pas trouvé, même en création automatique..) et aussi que cela soit répercuté dans « 2.Overview » à la suite des autres concurrents.
3. On a donc NOM : en sheets(« NOM ») et en sheets(« NOM »).Range(« B3 »), et en sheets(« 2.Overview ») en colonne A en dernière position. Ce qu’il me faut désormais, c’est faire un lien hypertexte entre les deux feuilles.
4. Enfin, trier les feuilles de A a Z

Merci par avance à tous ceux qui pourront m'aider!
Afficher la suite 

Votre réponse

7 réponses

Meilleure réponse
Messages postés
5599
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
10 décembre 2018
3
Merci
L'erreur se situe à
"=VLOOKUP(R2C,Reponse!C1:C2,2,FALSE)"
je ne comprends pas très bien ce que représente R2C, il faudrait un peu plus de précision.
En attendant je t'ai fait cela pendant le WE sur ta demande créer des liens hypertexte et trier les onglets.
Dans un nouveau classeur tu mets un UserForm avec 5 Button avec ce code pour voir le fonctionnement:
Option Explicit
Private Sub CommandButton1_Click()
NouvelleFeuille
End Sub
Private Sub CommandButton2_Click()
Triercolonne_croissant
End Sub
Private Sub CommandButton3_Click()
Triercolonne_decroissant
End Sub
Private Sub CommandButton4_Click()
TrierFeuilles_croissant
End Sub
Private Sub CommandButton5_Click()
TrierFeuilles_decroissant
End Sub
Sub NouvelleFeuille()
Dim Sh As Worksheet
Dim Reponse As String
Dim MonNom As String
Dim BonNom As Boolean
Dim LeString
Dim supp
Dim ligne As Integer
Dim a As Integer
LeString = ":\/?*[]"

Do
    BonNom = True
    Reponse = InputBox("Quel nom désirez-vous donner à la" _
        + vbCrLf + "nouvelle feuille de votre classeur?", _
        "Baptisez votre feuille ", MonNom)
    If Reponse <> "" Then
       'Vérifier que le nom n'existe pas déjà...
        For a = 1 To ActiveWorkbook.Worksheets.Count
            If UCase(Reponse) = UCase(Worksheets(a).Name) Then
                supp = MsgBox( _
                    "Vous possédez une feuille portant déjà ce nom," _
                    + vbCrLf + vbCrLf + _
                    "Désirez-vous la remplacer?.", vbYesNo + vbOKOnly, _
                    "Nom existant déjà")
                If supp = vbYes Then
                    Application.DisplayAlerts = False
                    Worksheets(Reponse).Delete
                    Application.DisplayAlerts = True
                    Exit For
                Else
                    BonNom = False
                    MonNom = Reponse
                    Exit For
                End If
            End If
        Next
        
        'Vérifier que le nombre de caractères du nom ne dépassent 31...
        If Len(Reponse) > 31 Then
            MsgBox "Le nombre de caractères (" & _
                Len(Reponse) & ") de votre nom dépasse" _
                + vbCrLf + " celui permis (31) par excel.", _
                vbCritical + vbInformation, "Nom trop long"
            BonNom = False
            MonNom = Reponse
        End If
        
        'Vérifier l'emploi de caractères interdits...dans le nom
        For a = 1 To Len(LeString)
            If InStr(1, Reponse, Mid(LeString, a, 1), vbTextCompare) > 0 Then
                MsgBox "Les caractères suivants:  " & _
                LeString & "  sont interdits" _
                + vbCrLf + "dans le nom d'une feuille.", _
                vbCritical + vbOKOnly, "Caractère interdit"
                BonNom = False
                MonNom = Reponse
                Exit For
            End If
        Next
    Else
        Exit Sub
    End If
Loop Until BonNom = True

Set Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Sh.Name = Reponse
 
 'sélection interface
Worksheets("Feuil1").Select
'dernière ligne feuille active, colonne A
  ligne = Cells(Cells.Rows.Count, "A").End(xlUp).Row

'lien hypertexte vers nouvelle feuille
 Range("A" & ligne).Select 'sélection dernière ligne
 If Range("A1").Value = "" Then 'pour la 1ère utilisation
 ActiveCell.FormulaR1C1 = Reponse 'Nom de la feuille
Else
    ActiveCell.Offset(1, 0).Select 'sélection cellule en dessous
    ActiveCell.FormulaR1C1 = Reponse 'Nom de la feuille
    End If
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        Reponse & "!A1", TextToDisplay:=Reponse
    
    'sélection nouvelle feuille
    Worksheets(Reponse).Select
   'lien hypertexte vers l'interface
    Range("A1").Select
    ActiveCell.FormulaR1C1 = Reponse  'Nom de la feuille
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
       "Feuil1!A1", TextToDisplay:="Retour " & "Feuil1"
    End Sub
Sub Triercolonne_croissant()
  'sélection interface
Worksheets("Feuil1").Select
 Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub
Sub Triercolonne_decroissant()
 'sélection interface
Worksheets("Feuil1").Select
Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub
Sub TrierFeuilles_croissant()
'attention : feuil11 est trié entre feuil1 et feuil2
Dim I As Integer, J As Integer, K As Integer
    Application.ScreenUpdating = False
    For I = 1 To Sheets.Count
        J = I
        For K = I + 1 To Sheets.Count
            If Sheets(K).Name < Sheets(J).Name Then J = K
        Next K
        If J <> I Then Sheets(J).Move Sheets(I)
    Next I
End Sub
Sub TrierFeuilles_decroissant()
'attention : feuil11 est trié entre feuil1 et feuil2
Dim I As Integer, J As Integer, K As Integer
    Application.ScreenUpdating = False
    For I = 1 To Sheets.Count
        J = I
        For K = I + 1 To Sheets.Count
            If Sheets(K).Name > Sheets(J).Name Then J = K
        Next K
        If J <> I Then Sheets(J).Move Sheets(I)
    Next I
End Sub



Ensuite tu n'auras plus qu'a l'adapter en changeant le nom de l'interface et la cellule A1

Merci cs_Le Pivert 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources a aidé 97 internautes ce mois-ci

Commenter la réponse de cs_Le Pivert
Messages postés
5599
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
10 décembre 2018
0
Merci
Bonjour,
Regarde ceci, cela te permettra d'avancer:

http://frederic.sigonneau.free.fr/code/Feuilles/AjouterEtNommerFeuilleClasseur.txt

@+Le Pivert
Commenter la réponse de cs_Le Pivert
Messages postés
4
Date d'inscription
vendredi 17 juin 2011
Dernière intervention
22 juin 2011
0
Merci
Merci énormément Le Pivert!

Grâce à toi j'ai pu bien avancer. J'ai réussi à compléter le code que tu m'a transmis avec ce qu'il me fallait en plus, touefois, je reste juste bloqué au moment de faire une RECHERCHEV, car cela ne me trouve pas le nom de l'onglet en mettant (Reponse)... Je cherche à mettre dans l'onglet "2.Overview" tout ce qui sera tapé dans le nouvel onglet (Reponse), mais ça bloque lorsque la fonction cherche la base.

Une idée?


[i]Sheets("2.Overview").Select
Range("A60").Select
ActiveCell.FormulaR1C1 = Reponse
'Recherche V et etendre la selection

Range("B60").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C,Reponse!C1:C2,2,FALSE)"
Range("B60").Select
selection.AutoFill Destination:=Range("B60:CX60"), Type:=xlFillDefault
Range("B60:CX60").Select/i
Commenter la réponse de cs_Vincent58
Messages postés
4
Date d'inscription
vendredi 17 juin 2011
Dernière intervention
22 juin 2011
0
Merci
Merci pour les informations supplémentaires! J'avais trouvé une méthode pour le tri des onglets que j'ai rajouté avec succès à ton code. L'hypertexte, pour l'instant ne marche pas mais c'est parce que tout n'est pas encore complet. J'essaie de tout mettre dans la même sub pour ne pas être gêné par le "Reponse".

D'après Google, R2C correspondrait aux rangées et aux colonnes. Cependant, dans les autres lignes où j'avais tapé à la main la fonction, ça me donnait la formule suivante: "= RECHERCHEV(B$2; nom_onglet !$A:$B;2;FAUX)", celle que je veux étendre de B$2 à CX$2.

Je te mets ici le code en entier à son état actuel, peut être que ce te sera plus clair. La partie à la fin en vert est celle où je suis bloqué..

Encore merci

Sub Add_competitor()

Dim Sh As Worksheet
Dim Reponse As String
Dim MonNom As String
Dim BonNom As Boolean
Dim LeString
LeString  = ":\/?*[]"

Do
    BonNom = True
    Reponse = InputBox("Please write here the name of the competitor", _
        "Name of the sheet", MonNom)
    If Reponse <> "" Then
       'Vérifier que le nom n'existe pas déjà...
        For a = 1 To ActiveWorkbook.Worksheets.Count
            If UCase(Reponse) = UCase(Worksheets(a).Name) Then
                supp = MsgBox( _
                    "Competitor already exists (or this sheet already exists)" _
                    + vbCrLf + vbCrLf + _
                    "Would you like to replace it?.", vbYesNo + vbOKOnly, _
                    "Name already existing")
                If supp = vbYes Then
                    Application.DisplayAlerts = False
                    Worksheets(Reponse).Delete
                    Application.DisplayAlerts = True
                    Exit For
                Else
                    BonNom = False
                    MonNom = Reponse
                    Exit For
                End If
            End If
        Next
        
        'Vérifier que le nombre de caractères du nom ne dépassent 31...
        If Len(Reponse) > 31 Then
            MsgBox "Le nombre de caractères (" & _
                Len(Reponse) & ") de votre nom dépasse" _
                + vbCrLf + " celui permis (31) par excel.", _
                vbCritical + vbInformation, "Name too long"
            BonNom = False
            MonNom = Reponse
        End If
        
        'Vérifier l'emploi de caractères interdits...dans le nom
        For a = 1 To Len(LeString)
            If InStr(1, Reponse, Mid(LeString, a, 1), vbTextCompare) > 0 Then
                MsgBox "Les caractères suivants:  " & _
                LeString & "  sont interdits" _
                + vbCrLf + "dans le nom d'une feuille.", _
                vbCritical + vbOKOnly, "Forbidden caracter"
                BonNom = False
                MonNom = Reponse
                Exit For
            End If
        Next
    Else
        Exit Sub
    End If
Loop Until BonNom = True

Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = Reponse

' Tier les feuilles de A a Z

    Dim Boucle As Integer, Compteur As Integer

    For Boucle = 1 To Sheets.Count
        If Sheets(Boucle).Visible = True Then
           For Compteur = 1 To (Boucle - 1)
               If Sheets(Compteur).Visible = True Then
                    If (UCase(Sheets(Boucle).Name) < UCase(Sheets(Compteur).Name)) Then
                        Sheets(Boucle).Move before:=Sheets(Compteur)
                        Exit For
                    End If
               End If
           Next Compteur
        End If
    Next Boucle
    

'
' Get info from 4.Example, copy paste it all in the new sheet
'
    Sheets("4.Example").Select
    Cells.Select
    selection.Copy
    Range("A1").Select
    Sheets(Reponse).Select
    ActiveSheet.Paste
    Range("A1").Select
    Rows("1:1").RowHeight = 91.5
    Sheets("4.Example").Select
Application.CutCopyMode = False
Sheets(Reponse).Select
Range("A1").Select
ActiveWindow.Zoom = 90

' Name Cell B3 (company name)
'
    Range("B3").FormulaR1C1 = Reponse
    With Range("B3").Characters(Start:=1, Length:=7).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
' Nommer la cellule dans overview

Sheets("2.Overview").Select
Range("A60").Select 'Mettre le nom de la nouvelle compagnie en bas d'une liste avec assez d'espace entre celles existantes et A60
ActiveCell.FormulaR1C1 = Reponse


'Recherche V et etendre la selection

'  Range("B60").Select
 '   ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C,Reponse!C1:C2,2,FALSE)"
  '  Range("B60").Select
   ' selection.AutoFill Destination:=Range("B60:CX60"), Type:=xlFillDefault
    'Range("B60:CX60").Select

'Sub Tri_Overview()
'
' Tri_Overview Macro
'

'
   ' Sheets("2.Overview").Select
    'Range("A3:CX60").Select
    'ActiveWorkbook.Worksheets("2.Overview").Sort.SortFields.Clear
    'ActiveWorkbook.Worksheets("2.Overview").Sort.SortFields.Add Key:=Range("A3") _
     '   , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    'With ActiveWorkbook.Worksheets("2.Overview").Sort
    '    .SetRange Range("A4:CX60")
     '   .Header = xlNo
      '  .MatchCase = False
       ' .Orientation = xlTopToBottom
        '.SortMethod = xlPinYin
        '.Apply
    'End With

Sheets(Reponse).Select
Range("A1").Select


End Sub
Commenter la réponse de cs_Vincent58
Messages postés
5599
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
10 décembre 2018
0
Merci
Cette ligne ouvre une boite de dialogue pour une recherche dans un autre classeur
ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C,Reponse!C1:C2,2,FALSE)"

Si c'est ce que tu recherches il faut revoir ta formule en faisant une recherche sur le net
VLOOKUP
Sinon si c'est une recherche dans le classeur ouvert il faut employer
ActiveCell.FormulaR1C1 = "=RechercheV(R2C,Reponse,C1:C2,2,FALSE)"

et revoir ta formule
RechercheV
Commenter la réponse de cs_Le Pivert
Messages postés
5599
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
10 décembre 2018
0
Merci
Regarde ceci , c'est bien expliqué pour les 2 cas

http://www.excel-downloads.com/forum/89268-recherchev-en-vba.html
Commenter la réponse de cs_Le Pivert
Messages postés
4
Date d'inscription
vendredi 17 juin 2011
Dernière intervention
22 juin 2011
0
Merci
Merci pour tout Le Pivert!

J'ai pu finir ma base en temps et en heure grâce à toi! C'était une recherche dans un classeur ouvert que je recherchais, j'ai fini par utiliser:

Range("B60").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C," & Reponse & "!C1:C2,2,FALSE)"
Commenter la réponse de cs_Vincent58

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.