XL 2019 Probleme de code VBA

Richard 58

XLDnaute Nouveau
Bonjour à tous,
Pouvez vous m'aider à trouver l'erreur dans mon code ?
Lorsque je clique sur valider, mes donner de mon userform ne s'affiche pas les uns en dessous des autres. Une données remplace l'autres dans le tableau (recap)
Code:
Private Sub CommandButton1_Click()
Dim OE As Worksheet 'déclare la variable OE (Onglet Existant)
Dim NomSalle As String
Dim hde As String
Dim ha As String
Dim valhde As String
Dim valha As String
Dim lassociation As String
Dim lejour As String
Dim lheurede As String
Dim lheurea As String

    Dim lignede As Variant
    Dim plageSel As Range
    Dim col As Integer
    Dim L As Integer

NomSalle = ComboBox2.Value

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set OE = Worksheets(NomSalle) 'définit l'onglet OE (génère une erreur si cet onglet n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Worksheets("Modele").Copy after:=Worksheets("Modele") 'copie l'onglet Modèle après ljui-même
    ActiveSheet.Name = NomSalle 'renome l'onglet actif
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs

lassociation = ComboBox1.Value
lejour = ComboBox3.Value
lheurede = ComboBox4.Value
lheurea = ComboBox5.Value


Call TraitementAssoc

With Worksheets("Recap")
L = .Range("a65536").End(xlUp).Row + 1 'Pour placer le nouvel enregistrement à la première ligne de tableau non vide
 
        .Range("A" & L).Value = NomSalle
        .Range("B" & L).Value = lassociation
        .Range("C" & L).Value = lejour
        .Range("D" & L).Value = lheurede
        .Range("E" & L).Value = lheurea
    End With
    
Sheets("Recap").Select
Range("A1").End(xlDown).Offset(1, 0).Select
ligne = ActiveCell.Row
ActiveCell.Value = NomSalle
ligne = ActiveCell.Row
Cells(ligne, 2).Select
ActiveCell.Value = lassociation
Cells(ligne, 3).Select
ActiveCell.Value = lejour
Cells(ligne, 4).Select
ActiveCell.Value = lheurede
hde = ActiveCell.Value
Cells(ligne, 5).Select
ActiveCell.Value = lheurea
ha = ActiveCell.Value
Sheets(NomSalle).Select

Worksheets(NomSalle).Select
'Détermination de la ligne de et de la ligne à pour le planing
lig = 4
col = 1
Cells(lig, col).Select
Do While ActiveCell.Value <> ""
    valhde = ActiveCell.Value
    If valhde = hde Then
        lignede = ActiveCell.Row
        Exit Do
    End If
    lig = lig + 1
    Cells(lig, col).Select
Loop
lig = 4
col = 2
Cells(lig, col).Select
Do While ActiveCell.Value <> ""
    valha = ActiveCell.Value
    If valha = ha Then
        lignea = ActiveCell.Row
        Exit Do
    End If
    lig = lig + 1
    Cells(lig, col).Select
Loop
'Recherche dans planing si la plage a affecter est deja prise
vide = 0
lde = lignede
la = lignea
Select Case lejour
    Case "Lundi"
        For I = lde To la
            Cells(I, 3).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 3), Cells(lignea, 3)).Select
    Case "Mardi"
        For I = lde To la
            Cells(I, 4).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 4), Cells(lignea, 4)).Select
    Case "Mercredi"
        For I = lde To la
            Cells(I, 5).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 5), Cells(lignea, 5)).Select
    Case "Jeudi"
        For I = lde To la
            Cells(I, 6).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 6), Cells(lignea, 6)).Select
    Case "Vendredi"
        For I = lde To la
            Cells(I, 7).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 7), Cells(lignea, 7)).Select
    Case "Samedi"
        For I = lde To la
            Cells(I, 8).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 8), Cells(lignea, 8)).Select
    Case "Dimanche"
        For I = lde To la
            Cells(I, 9).Select
            If ActiveCell.Value <> "" Then
                vide = 1
                Exit For
            End If
        Next
        Range(Cells(lignede, 9), Cells(lignea, 9)).Select
End Select

If vide = 1 Then
    MsgBox "Plage déjà occupée partiellement ou en totalité!!!"
    Worksheets("Recap").Select
    Range("A1").End(xlDown).Offset(0, 0).Select
    Selection.EntireRow.Delete
    Worksheets(NomSalle).Select
    Exit Sub
End If
'Affectation de la plage mise en gras ecriture bleue et fusion des cellules
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Orientation = 0
    .ShrinkToFit = False
    .MergeCells = True
End With
With Selection.Font
    .Name = "Arial"
    .FontStyle = "Gras"
    .Size = 10
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 5
End With
ActiveCell.FormulaR1C1 = lassociation
End Sub

Merci à vous
 

ChTi160

XLDnaute Barbatruc
Bonjour
dans cette partie de ta procédure il te faut réinitialiser ta variable Ligne
VB:
Sheets("Recap").Select
Range("A1").End(xlDown).Offset(1, 0).Select 'Ici tu définis la dernière ligne Vide
ligne = ActiveCell.Row 'Ici c'est bon
ActiveCell.Value = NomSalle 'ici c'est bon
ligne = ActiveCell.Row 'mais la t'as toujours la même ligne Cible
Cells(ligne, 2).Select
il te faut redéfinir la Ligne pour chaque Données
soit x
Range("A1").End(xlDown).Offset(1, 0).Select 'Ici tu définis la dernière ligne Vide
jean marie
 

Statistiques des forums

Discussions
313 198
Messages
2 096 135
Membres
106 504
dernier inscrit
Kannankin Maxime