Titre du sujet : Re: gestion de l'insertion de lignes et de la saisie sur ces lignes
par myDearFriend! le 22/10/2009 00:33:27
Re,
Tu trouveras dans le fichier joint, les modifications demandées.
DANS LE MODULE DE CODE DE LA FEUILLE "cars" : une procédure évènementielle est ajoutée pour contrôler la saisie directe sur feuille
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Plage As Range
If Target.Count > 1 Then Exit Sub 'ne gère pas les sélections de plage
Set Plage = vPlage
With Application
If Not .Intersect(Target, Plage.Offset(0, 3).Resize(, Plage.Columns.Count - 3)) Is Nothing Then
If .CountA(Plage.Columns(Target.Column)) > 8 Then
MsgBox "Déjà 8 modèles pour ce lieu !"
.Undo
End If
End If
End With
End Sub
DANS LE MODULE DE CODE STANDARD mDF : une nouvelle fonction personnalisée est ajoutée
Function vPlage() As Range
Dim L As Long
Dim C As Integer
With Sheets("cars")
C = .Cells(3, .Columns.Count).End(xlToLeft).Column 'nbre de colonnes maxi
L = .Cells(.Rows.Count, 1).End(xlUp).Row 'nbre de lignes maxi
Set vPlage = .Range(.Cells(5, 1), .Cells(L, C))
End With
End Function
LE MODULE DE CODE DU USERFORM est également modifié comme suit :
Option Explicit
'--------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 22/10/2009
'--------------------------------------------------------------------------
Private Sub UserForm_Initialize()
Dim maxCol As Integer
Dim C As Byte, i As Byte
'Détermination du nombre de lieux maxi
maxCol = vPlage.Columns.Count
'Chargement des ComboBox correspondantes
For C = 1 To 5
With Controls("cboLieu" & C)
.ColumnCount = 2
.BoundColumn = 2
.ColumnWidths = ";0"
For i = 1 To maxCol - 3
.AddItem Sheets("cars").Cells(3, i + 3).Text
.List(.ListCount - 1, 1) = i
Next i
End With
Next C
End Sub
Private Sub btnParcourir1_Click()
Parcourir txtLien1
End Sub
Private Sub btnParcourir2_Click()
Parcourir txtLien2
End Sub
Private Sub btnParcourir3_Click()
Parcourir txtLien3
End Sub
Private Sub btnParcourir4_Click()
Parcourir txtLien4
End Sub
Private Sub btnParcourir5_Click()
Parcourir txtLien5
End Sub
Private Sub Parcourir(Ctrl As Control)
Dim Chemin As Variant
Chemin = Application.GetOpenFilename("Fichier image (*.bmp; *.jpg; *.gif; *.png),*.bmp;*.jpg;*.gif;*.png", , "Choisir fichier image...")
If Not Chemin = False Then
Ctrl.Text = Chemin
End If
End Sub
Private Sub btnInserer_Click()
Dim Ctrl As Control
Dim i As Byte, N As Byte
Dim Ok As Boolean
'Contrôle la cohérence de la saisie
If txtModele.Text = "" Then Exit Sub
For i = 1 To 5
If Controls("cboLieu" & i).ListIndex > -1 And Controls("txtLieu" & i).Text <> "" And Controls("txtlien" & i).Text <> "" Then
N = Controls("cboLieu" & i).ListIndex
'8 modèles maximum par lieu
If Sheets("cars").Cells(2, 4 + N) > 7 Then
MsgBox "Le lieu " & Controls("cboLieu" & i).Text & " contient déjà 8 modèles !"
Ok = False
Exit For
Else
Ok = True
End If
End If
Next i
If Ok Then
With Sheets("cars")
'Créer nouvelle ligne
.Rows("10").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Recopier les formules en A et B
.Range(.Cells(9, 1), .Cells(9, 2)).Copy
.Range(.Cells(10, 1), .Cells(10, 2)).PasteSpecial Paste:=xlPasteFormulas
Application.CutCopyMode = False
'Insérer les données
.Cells(10, 3).Value = txtModele
InsereLien cboLieu1.ListIndex, txtLien1, txtLieu1
InsereLien cboLieu2.ListIndex, txtLien2, txtLieu2
InsereLien cboLieu3.ListIndex, txtLien3, txtLieu3
InsereLien cboLieu4.ListIndex, txtLien4, txtLieu4
InsereLien cboLieu5.ListIndex, txtLien5, txtLieu5
End With
'RAZ formulaire (préparation pour saisie "de masse")
For Each Ctrl In Me.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
Ctrl.Text = ""
Case "ComboBox"
Ctrl.ListIndex = -1
End Select
Next Ctrl
End If
End Sub
Private Sub InsereLien(Id As Integer, Lien As String, Titre As String)
'Insère le lien dans la feuille
Dim R As Range
If Id < 0 Or Lien = "" Or Titre = "" Then Exit Sub
With Sheets("cars")
Set R = .Cells(10, 4 + Id)
.Hyperlinks.Add Anchor:=R, Address:=Lien
R.Hyperlinks(1).TextToDisplay = Titre
End With
End Sub
Private Sub btnFin_Click()
Dim Plage As Range
Dim L As Long
'Trier la base
Application.ScreenUpdating = False
With Sheets("cars")
Set Plage = vPlage
Plage.Sort Key1:=.Range("C5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.ScreenUpdating = True
'Fermer le formulaire
Unload Me
'Enregistrer sous...
Application.Dialogs(xlDialogSaveAs).Show
End Sub
Private Sub btnAnnuler_Click()
Unload Me
End Sub
J'en ai profité pour modifier notamment un problème du code précédent que je n'avais pas vu : la plage triée était limitée (à tort) à la colonne H. C'est rectifié maintenant.
Cordialement,
|
Didier FOURGEOT