I have a template which represents a data table for the days of the week, I want to protect the template for modification (I done that), and when I press the button "Insert a new sheet for the next week", I get a copy of the template but it's not protected like the template.
How can I do That ?
There is my code :
Sub Bouton_NewSheet()
Dim NumSemaine As String
NumSemaine = InputBox("Veuillez entrer le numéro de la semaine :", "Insertion d'une feuille vierge")
If NumSemaine <> "" Then
'vérifier si valeur nuémrique
While Not IsNumeric(NumSemaine)
MsgBox "Merci de saisir une valeur numérique", vbExclamation
NumSemaine = InputBox("Veuillez entrer un numéro de semaine", "Insertion d'une feuille vierge")
Wend
Sheets("Template").Visible = True
Sheets("Template").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = "S" & NumSemaine
ActiveSheet.Range("B1").Value = "S" & NumSemaine
Sheets("Template").Visible = True
MsgBox "Votre feuille de suivi de stock est pour la semaine N°" & NumSemaine
End If
Sheets("Template").Protect
End Sub
Thank you
Related
I have create with many help a code who create with a user form a new sheet with the name of the client and many other information. And in the first page who resume all name client i have made an hyperlink (column C) who send to queue name of the client. But with the userform a error 424 appears.
Private Sub btnajoutclient_Click()
Dim numFeuilClient As String
Dim prenomFeuilClient As String
Dim telFeuilClient As String
Dim mailFeuilClient As String
Dim AdresseFeuilClient As String
Dim cpFeuilClient As String
Dim villeFeuilClient As String
'RENDRE LES FEUILLES VISIBLES'
Worksheets(2).Visible = True
Worksheets(3).Visible = True
'CREER 2 BOITES POUR AVOIR LES INFOS : NOM ET TEL'
numFeuilClient = frmnouveauclient.TextBoxcasenom
prenomFeuilClient = frmnouveauclient.TextBoxprénom
telFeuilClient = frmnouveauclient.TextBoxcasenumérotel
mailFeuilClient = frmnouveauclient.TextBoxcasemail
AdresseFeuilClient = frmnouveauclient.TextBoxcaseadresse
cpFeuilClient = frmnouveauclient.TextBoxcasecodepostal
villeFeuilClient = frmnouveauclient.TextBoxcaseville
'freezer lécran
Application.ScreenUpdating = False
'SI PAS DE NOM SAISIE ALORS EXIT'
If numFeuilClient = "" Then
Worksheets(2).Visible = False
Worksheets(3).Visible = False
Exit Sub
End If
'ON SUPPRIME LA ZONE SELECTIONNER LA FEUILLE TYPE'
Sheets("FeuilClient").Range("_zonesuprfinal").ClearContents
Sheets("FeuilClient").Copy after:=Sheets(Sheets.Count)
'RENOMMER LA FEUILLE
ActiveSheet.Name = numFeuilClient
'ON MET LE NOM ET LE TEL DANS LES CASES SELECTIONEE DE LA FEUILLE CLIENT'
ActiveSheet.Range("_nomclient").Value = numFeuilClient
ActiveSheet.Range("_telclient").Value = telFeuilClient
ActiveSheet.Range("_prenomclient").Value = prenomFeuilClient
ActiveSheet.Range("_mailclient").Value = mailFeuilClient
ActiveSheet.Range("_adresse").Value = AdresseFeuilClient
ActiveSheet.Range("_codepostal").Value = cpFeuilClient
ActiveSheet.Range("_ville").Value = villeFeuilClient
'Aller sur la feuille fichier client
Sheets(1).Activate
'On trouve une case vide et y met le nom sur le fichier client
Feuil3.Range("A1048000").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = numFeuilClient
'On trouve une case vide et y met le nom sur le tel du client
Sheets("FichierClient").Range("B1048000").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = telFeuilClient
'Mettre un hyperlien sur le fichierclient
Sheets("FichierClient").Range("C1048000").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Hyperlinks.Add Anchor:=ActiveCell, Address:="", _
SubAddress:="'" & numFeuilClient & "'!A1", TextToDisplay:="Voir Client"
'ON REND INSIVIBLE LES FEUILLES'
Worksheets(2).Visible = False
Worksheets(3).Visible = False
'défreezer l'écran
Application.ScreenUpdating = True
End Sub
Hyperlinks needs to be qualified to a Worksheet
The simple fix is change it to
ActiveSheet.HyperLinks.Add ...
That said, there is a lot of opportunity to improve this code. Consider this
Private Sub btnajoutclient_Click()
Dim numFeuilClient As String
Dim prenomFeuilClient As String
Dim telFeuilClient As String
Dim mailFeuilClient As String
Dim AdresseFeuilClient As String
Dim cpFeuilClient As String
Dim villeFeuilClient As String
Dim wsFeuilClient As Worksheet
With ThisWorkbook ' or ActiveWorkbook or specify a workbook
'RENDRE LES FEUILLES VISIBLES'
.Worksheets(2).Visible = True
.Worksheets(3).Visible = True
'CREER 2 BOITES POUR AVOIR LES INFOS : NOM ET TEL'
With frmnouveauclient
numFeuilClient = .TextBoxcasenom
'SI PAS DE NOM SAISIE ALORS EXIT'
If numFeuilClient = vbNullString Then
GoTo CleanUp
End If
prenomFeuilClient = .TextBoxprénom
telFeuilClient = .TextBoxcasenumérotel
mailFeuilClient = .TextBoxcasemail
AdresseFeuilClient = .TextBoxcaseadresse
cpFeuilClient = .TextBoxcasecodepostal
villeFeuilClient = .TextBoxcaseville
End With
'freezer lécran
Application.ScreenUpdating = False
'ON SUPPRIME LA ZONE SELECTIONNER LA FEUILLE TYPE'
.Worksheets("FeuilClient").Range("_zonesuprfinal").ClearContents
Set wsFeuilClient = .Worksheets("FeuilClient").Copy(after:=.Sheets(.Sheets.Count))
'RENOMMER LA FEUILLE
With wsFeuilClient
.Name = numFeuilClient
'ON MET LE NOM ET LE TEL DANS LES CASES SELECTIONEE DE LA FEUILLE CLIENT'
.Range("_nomclient").Value = numFeuilClient
.Range("_telclient").Value = telFeuilClient
.Range("_prenomclient").Value = prenomFeuilClient
.Range("_mailclient").Value = mailFeuilClient
.Range("_adresse").Value = AdresseFeuilClient
.Range("_codepostal").Value = cpFeuilClient
.Range("_ville").Value = villeFeuilClient
End With
'Aller sur la feuille fichier client
With .Sheets(1)
'On trouve une case vide et y met le nom sur le fichier client
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = numFeuilClient
End With
With .Worksheets("FichierClient")
'On trouve une case vide et y met le nom sur le tel du client
.Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0).Value = numFeuilClient
'Mettre un hyperlien sur le fichierclient
With .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
.Value = numFeuilClient
.Worksheet.Hyperlinks.Add Anchor:=.Cells, Address:=vbNullString, _
SubAddress:="'" & numFeuilClient & "'!A1", TextToDisplay:="Voir Client"
End With
End With
CleanUp:
'ON REND INSIVIBLE LES FEUILLES'
.Worksheets(2).Visible = False
.Worksheets(3).Visible = False
End With
'défreezer l'écran
Application.ScreenUpdating = True
End Sub
I have a ComboBox "Liste_cible" with values like: BOCAL SAP-A246, or PAP-SAP-K207.
I would like to use only the last number, after the "-" (A246 or K207) to run another subroutine.
I'm looking for the function like SUBTSTR(Me.Liste_cible.Value,”-“,-1)
Private Sub liste_cible_Change()
Dim argString As String
If Not Worksheets("1 - Feuille de Suivi Commercial").Liste_cible.MatchFound And Worksheets("1 -
Feuille de Suivi Commercial").Liste_cible <> "" Then
MsgBox "Saisie impossible, ce partenaire cible n'existe pas !", , "Contrôle"
Worksheets("1 - Feuille de Suivi Commercial").Liste_cible = ""
Else
Worksheets("1 - Feuille de Suivi Commercial").Cells(5, 17) = Worksheets("1 - Feuille de Suivi
Commercial").Liste_cible
MsgBox Me.Liste_cible.Value
argString = SUBTSTR(Me.Liste_cible.Value,”-“,-1) ??
GET_GROUPE_GESTION_CIBLE (argString)
INFO_PROTO1 (argString)
INFO_PROTO2 (argString)
End If
End Sub
MsgBox Me.Liste_cible.Value works correctly, but I don't know how to get the argString.
This should do the trick:
argString = Mid(Me.Liste_cible.Value, InStrRev(Me.Liste_cible.Value,"-") + 1)
I need to compare between two excel files. i have data of Week S-1 and i need to know what are the transformations that happened to my data in the next week S1.
my data is grouped with a called " Code fonction"
For each "Code fonction" i need to know what are the transformations ( modifications, rows added or deleted rows).
i tried to make a code i worked with the logic to compare row per row, and i made the condition that the "code fonction" must be the same in the rows compared. but the code didn't give me the results that i wanted.
Option Explicit
Private Sub CommandButton1_Click()
Dim strRepFicA As String, strRepFicB As String
Dim wbFicA As Workbook, wbFicB As Workbook, wbFicAna As Workbook
Dim wsFicA As Worksheet, wsFicB As Worksheet, wsFicAna As Worksheet
Dim lgLig As Long, lgCol As Long
Dim lgLigDeb As Long
' Répertoire et Fichier
strRepFicA = ThisWorkbook.Path & "\" & "S-1.xlsx"
strRepFicB = ThisWorkbook.Path & "\" & "S1.xlsx"
' Classeur d'analyse
Set wbFicAna = ThisWorkbook
Set wsFicAna = wbFicAna.ActiveSheet
' Vérifier que les fichiers A et B se trouvent dans le répertoire
If Dir(strRepFicA) = "" Or Dir(strRepFicB) = "" Then
MsgBox "Le fichier A et/ou le fichier B sont introuvables", vbCritical + vbOKOnly, "Problème de fichiers..."
Exit Sub
End If
Application.ScreenUpdating = False
' Ouverture du fichier A et définition de la feuille de traitement
Set wbFicA = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "S-1.xlsx")
Set wsFicA = wbFicA.Worksheets("Sheet1")
' Ouverture du fichier B et définition de la feuille de traitement
Set wbFicB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "S1.xlsx")
Set wsFicB = wbFicB.Worksheets("Sheet1")
' Vider les lignes du fichier d'analyse
wsFicAna.Range("A2:U" & Cells.Rows.Count).ClearContents
' Première ligne d'affichage des résultats dans le fichier d'analyse
lgLigDeb = 2
' Traitement des lignes des 2 fichiers
' Lignes : 2 à 1250
For lgLig = 2 To 7000
' Colonnes : D à AO
' Une différence est trouvée dans une ligne
'wsFicA.Cells(lgLig, lgCol).Value <> wsFicB.Cells(lgLig, lgCol).Value
If wsFicA.Cells(lgLig, 9).Value <> wsFicB.Cells(lgLig, 9).Value And wsFicA.Cells(lgLig, 5).Value = wsFicB.Cells(lgLig, 5).Value Then
' Affichage du nom du fichier en colonne A
wsFicAna.Range("A" & lgLigDeb).Value = wbFicA.Name
' Copier la ligne du fichier A dans le fichier d'analyse
wsFicA.Range("B" & lgLig & ":" & "U" & lgLig).Copy _
Destination:=wsFicAna.Range("B" & lgLigDeb)
' Affichage du nom du fichier en colonne A
wsFicAna.Range("A" & lgLigDeb + 1).Value = wbFicB.Name
' Copier la ligne du fichier B dans le fichier d'analyse
wsFicB.Range("B" & lgLig & ":" & "U" & lgLig).Copy _
Destination:=wsFicAna.Range("B" & lgLigDeb + 1)
lgLigDeb = lgLigDeb + 2
End If
Next lgLig
' Fermer les fichiers A et B
wbFicA.Close savechanges:=False
wbFicB.Close savechanges:=False
MsgBox "Traitement terminé"
Application.ScreenUpdating = True
End Sub
I have created some UDF to automate some calculus me and some coworkers use regularly.
For the sake of simplicity I paste a MWE of what I have a problem with, my actual code is longer, but takes the same input, a range of cells with one of the dimensions being equal to one (so one line or one column)
Public Function Test(Donnees As Range)
Dim Nombre_Cellules, Temp As Double
Dim Format_Donnees As String
Temp = 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' '
' Parametres utiles generaux '
' '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Nb_Lignes = Donnees.Rows.Count
Nb_Colonnes = Donnees.Columns.Count
Premiere_Ligne = Donnees.Row
Premiere_Colonne = Donnees.Column
Derniere_Ligne = Donnees.Row + Nb_Lignes - 1
Derniere_Colonne = Donnees.Column + Nb_Colonnes - 1
'On definit la frequence et la taille associee
If Nb_Lignes = 1 Then
Format_Donnees = "Colonnes"
Nombre_Cellules = Nb_Colonnes
End If
If Nb_Colonnes = 1 Then
Format_Donnees = "Lignes"
Nombre_Cellules = Nb_Lignes
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' '
' Verifications des parametres et messages d'erreurs '
' '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'On verifie que la plage renseignée est soit sur une seule ligne soit sur une seule colonne
If (Nb_Lignes <> 1 And Nb_Colonnes <> 1) Then
MsgBox _
"La plage de données considérée est incorrecte, il ne peut s'agir que " & vbNewLine & _
Chr(149) & " de données sur une seule ligne ou " & vbNewLine & _
Chr(149) & " de données sur une seule colonne" _
, , "Parametres incorrects"
Test = CVErr(xlErrRef)
Exit Function
End If
'On verifie que toute la période qui sert au calcul contient bien des valeurs numériques et ne contient pas de valeurs vides
If Format_Donnees = "Lignes" Then
For i = 0 To Nombre_Cellules - 1
If Not IsNumeric(Cells(Premiere_Ligne + i, Premiere_Colonne).Value) Then
MsgBox _
"La plage de donnée considérée est incorrecte" & vbNewLine & _
"Toutes les cellules nécessaires au calcul dans la colonne ne sont pas numériques" _
, , "Parametres incorrects"
Test = CVErr(xlErrRef)
Exit Function
End If
If (Cells(Premiere_Ligne + i, Premiere_Colonne).Value = "") Then
MsgBox _
"La plage de donnée considérée est incorrecte" & vbNewLine & _
"Une cellule de la colonne considérée est vide et semble avoir une valeur manquante" _
, , "Parametres incorrects"
Test = CVErr(xlErrRef)
Exit Function
End If
Next
End If
If Format_Donnees = "Colonnes" Then
For i = 0 To Nombre_Cellules - 1
If Not IsNumeric(Cells(Premiere_Ligne, Premiere_Colonne + i).Value) Then
MsgBox _
"La plage de donnée considérée est incorrecte" & vbNewLine & _
"Toutes les cellules nécessaires au calcul dans la ligne ne sont pas numériques" _
, , "Parametres incorrects"
Test = CVErr(xlErrRef)
Exit Function
End If
If (Cells(Premiere_Ligne, Premiere_Colonne + i).Value = "") Then
MsgBox _
"La plage de donnée considérée est incorrecte" & vbNewLine & _
"Une cellule de la ligne considérée est vide et semble avoir une valeur manquante" _
, , "Parametres incorrects"
Test = CVErr(xlErrRef)
Exit Function
End If
Next
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' '
' Calculs a proprement parler '
' '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Format_Donnees = "Lignes" Then
For i = 0 To Nombre_Cellules - 1
Temp = Temp + Cells(Premiere_Ligne + i, Premiere_Colonne).Value
Next
End If
If Format_Donnees = "Colonnes" Then
For i = 0 To Nombre_Cellules - 1
Temp = Temp + Cells(Premiere_Ligne, Premiere_Colonne + i).Value
Next
End If
Test = Temp
End Function
So as I will not be the sole user of this function, I have tried to include several checks and error messages.
One is to check if the range selected has any empty values and any non numerical value.
Now my functions work (at least they calculate the thing I want them to), but I have some troubles with how they update.
Note that I have pushed against user preferences so that all the value used are included in the range passed in input.
One of the issues I have been able to reproduce with this code is that If I use this function on several sheets of one workbook (so one Test() in worksheet1, and one Test() in worksheet2, and for one reason try to update the whole workbook (e.g. via Ctrl + alt + shift + F9), then I will get one warning I have set up ("Une cellule de la ligne considérée est vide et semble avoir une valeur manquante") in a non active sheet.
Can someone explain me one ?
You are using Cells() with no sheet qualification. This means that it refers to whatever the active sheet happens to be. So it won't work correctly unless all the calls to your UDF are on the currently active sheet
You need to change this to Donnees.Cells( ) and change the Cell indexes to refer to the cells within Donnees rather than cells within the whole sheet
I want to force my users to either enter a value or press cancel.
here is my current code but I can't find how to state the used pressed OK without entering anything.
Thanks
InputBox:
On Error GoTo Cancel
var_TauxUS = InputBox("Veuillez aller sur www.xe.com et entrer le taux d'echange US/CAN:" & vbCrLf & vbCrLf & "Exemple: 1,26 (avec une virgule)", "TAUX US") 'La variable reçoit la valeur entrée dans l'InputBox
If StrPtr(var_TauxUS) = 0 Then
GoTo InputBox
ElseIf var_TauxUS <= 1 Then
MsgBox "Vous devez entrer un chiffre plus grand que 1"
GoTo InputBox
ElseIf var_TauxUS >= 1.35 Then
MsgBox "Vous devez entrer un chiffre plus petit que 1.36"
GoTo InputBox
Else
var_TauxUS = var_TauxUS + vECHANGEDEVISE 'Calculer l'échange de la devise
var_US = True
MsgBox "Nous commenceons a updater les prix à un taux de " & var_TauxUS & " - Merci!"
GoTo Programme
End If
I tried:
IsEmpty(var_TauxUS)
If var_TauxUS = "" then
and it's not working
Below is a sample to get you started:
Sub test()
Do
var_TauxUS = InputBox("Enter here:")
If StrPtr(var_TauxUS) = 0 Then
Exit Sub
End If
Loop While var_TauxUS = vbNullString
End Sub