Bonjour,
j'ai un pbl de code vba sur mon ordi lorsque je lance la macro code ci dessous, j'ai un message d'erreur qui s'affiche "Erreur de compilation, variable non definie":mad:j'ai tous essayé pourriez vous m'aider je vois pas du peut prevenir le pbl.
Merci d'avance de votre aide
Cordialement marouan
Option Explicit
Private Sub Worksheet_Activate()
Dim dptValid As String
Dim qualifValid As String
Dim i As Integer
Dim colors
On Error GoTo errHdl
If IsUpdated Then
If IsEmpty(source) Then SetGlobales
Me.Range("C4").Validation.Delete
For i = 0 To UBound(dpt)
If Not FindStr(dptValid, dpt(i)) Then
dptValid = dptValid & dpt(i) & ","
End If
Next i
With Me.Range("C4").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dptValid
.ErrorMessage = "Sélectionnez département dans la liste!"
End With
Me.Range("C4") = dpt(0)
Me.Range("C10").Validation.Delete
For i = 0 To UBound(qualif)
If Not FindStr(qualifValid, qualif(i)) Then
qualifValid = qualifValid & qualif(i) & ","
End If
Next i
Me.Range("C10").Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=qualifValid
Me.Range("C10") = qualif(0)
IsUpdated = False
End If
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'Worksheet_Activate')", vbExclamation, "Erreur"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cpValid As String
Dim villeValid As String
Dim entreprValid As String
Dim i As Integer
On Error GoTo errHdl
If Target.Address = "$C$4" Then
If IsEmpty(source) Then SetGlobales
Me.Range("C6").Validation.Delete
For i = 0 To UBound(dpt)
If Not FindStr(villeValid, ville(i)) And dpt(i) = Target Then
villeValid = villeValid & ville(i) & ","
End If
Next i
With Me.Range("C6").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=villeValid
.ErrorMessage = "Sélectionnez code postal dans la liste!"
End With
Me.Range("C6") = Split(villeValid, ",")(0)
ElseIf Target.Address = "$C$6" Then
If IsEmpty(source) Then SetGlobales
If Not IsEmpty(Target) Then
For i = 0 To UBound(ville)
If ville(i) = Target Then
Me.Range("C8") = cp(i)
Exit For
End If
Next i
Else: Me.Range("C8").ClearContents
End If
End If
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'Worksheet_Change')", vbExclamation, "Erreur"
End Sub
Public Sub FilterButton_Click()
Dim nb As Integer
Dim rng As Range
Dim i As Integer
Dim j As Integer
Application.ScreenUpdating = False
On Error GoTo errHdl
Me.Rows("16:65536").Delete
If IsEmpty(Me.Range("C4")) Then
Application.ScreenUpdating = True
With Me.Range("D4")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
Me.Range("C12") = 0
Application.ScreenUpdating = False
MsgBox "(*) champ 'Département' obligatoire!", vbInformation, "Recherche"
Exit Sub
Else
Me.Range("D4").ClearContents
End If
If (Not IsEmpty(Me.Range("C6")) And IsEmpty(Me.Range("C8"))) Or _
(IsEmpty(Me.Range("C6")) And Not IsEmpty(Me.Range("C8"))) Then
Application.ScreenUpdating = True
With Me.Range("D6")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
With Me.Range("D8")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
Me.Range("C12") = 0
Application.ScreenUpdating = False
MsgBox "champs 'ville/code postal' obligatoires!", vbInformation, "Recherche"
Exit Sub
Else
Me.Range("D6").ClearContents
Me.Range("D8").ClearContents
End If
If IsEmpty(source) Then SetGlobales
nb = 0
If IsEmpty(Me.Range("C6")) Then
For i = 2 To UBound(source, 1)
If Trim(source(i, 12)) = CStr(Me.Range("C4")) And Trim(source(i, 5)) = CStr(Me.Range("C10")) Then
nb = nb + 1
For j = 1 To UBound(source, 2)
Me.Cells(16 + nb, j + 1) = source(i, j)
Next j
End If
Next i
Else
For i = 2 To UBound(source, 1)
If Trim(source(i, 12)) = CStr(Me.Range("C4")) And Trim(source(i, 11)) = CStr(Me.Range("C6")) And _
Trim(source(i, 13)) = CStr(Me.Range("C8")) And Trim(source(i, 5)) = CStr(Me.Range("C10")) Then
nb = nb + 1
For j = 1 To UBound(source, 2)
Me.Cells(16 + nb, j + 1) = source(i, j)
Next j
End If
Next i
End If
Me.Range("C12") = nb
If nb <> 0 Then
For i = 1 To UBound(source, 2)
Me.Cells(16, i + 1) = source(1, i)
Next i
Set rng = Me.Range(Me.Cells(16, 2), Me.Cells(16, 2 + UBound(source, 2) - 1))
With rng.Rows(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
rng.Rows(1).Font.Bold = True
Set rng = Me.Range(Me.Cells(16, 2), Me.Cells(16 + nb, 2 + UBound(source, 2) - 1))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Me.Cells.EntireColumn.AutoFit
End If
Me.Cells.EntireRow.AutoFit
Application.ScreenUpdating = True
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'FilterButton_Click')", vbExclamation, "Erreur"
Application.ScreenUpdating = True
End Sub
Private Function FindStr(s1 As String, s2 As String) As Boolean
Dim i As Integer
Dim t() As String
t = Split(s1, ",")
For i = 0 To UBound(t)
If t(i) = s2 Then
FindStr = True
Exit Function
End If
Next i
FindStr = False
End Function
j'ai un pbl de code vba sur mon ordi lorsque je lance la macro code ci dessous, j'ai un message d'erreur qui s'affiche "Erreur de compilation, variable non definie":mad:j'ai tous essayé pourriez vous m'aider je vois pas du peut prevenir le pbl.
Merci d'avance de votre aide
Cordialement marouan
Option Explicit
Private Sub Worksheet_Activate()
Dim dptValid As String
Dim qualifValid As String
Dim i As Integer
Dim colors
On Error GoTo errHdl
If IsUpdated Then
If IsEmpty(source) Then SetGlobales
Me.Range("C4").Validation.Delete
For i = 0 To UBound(dpt)
If Not FindStr(dptValid, dpt(i)) Then
dptValid = dptValid & dpt(i) & ","
End If
Next i
With Me.Range("C4").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dptValid
.ErrorMessage = "Sélectionnez département dans la liste!"
End With
Me.Range("C4") = dpt(0)
Me.Range("C10").Validation.Delete
For i = 0 To UBound(qualif)
If Not FindStr(qualifValid, qualif(i)) Then
qualifValid = qualifValid & qualif(i) & ","
End If
Next i
Me.Range("C10").Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=qualifValid
Me.Range("C10") = qualif(0)
IsUpdated = False
End If
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'Worksheet_Activate')", vbExclamation, "Erreur"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cpValid As String
Dim villeValid As String
Dim entreprValid As String
Dim i As Integer
On Error GoTo errHdl
If Target.Address = "$C$4" Then
If IsEmpty(source) Then SetGlobales
Me.Range("C6").Validation.Delete
For i = 0 To UBound(dpt)
If Not FindStr(villeValid, ville(i)) And dpt(i) = Target Then
villeValid = villeValid & ville(i) & ","
End If
Next i
With Me.Range("C6").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=villeValid
.ErrorMessage = "Sélectionnez code postal dans la liste!"
End With
Me.Range("C6") = Split(villeValid, ",")(0)
ElseIf Target.Address = "$C$6" Then
If IsEmpty(source) Then SetGlobales
If Not IsEmpty(Target) Then
For i = 0 To UBound(ville)
If ville(i) = Target Then
Me.Range("C8") = cp(i)
Exit For
End If
Next i
Else: Me.Range("C8").ClearContents
End If
End If
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'Worksheet_Change')", vbExclamation, "Erreur"
End Sub
Public Sub FilterButton_Click()
Dim nb As Integer
Dim rng As Range
Dim i As Integer
Dim j As Integer
Application.ScreenUpdating = False
On Error GoTo errHdl
Me.Rows("16:65536").Delete
If IsEmpty(Me.Range("C4")) Then
Application.ScreenUpdating = True
With Me.Range("D4")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
Me.Range("C12") = 0
Application.ScreenUpdating = False
MsgBox "(*) champ 'Département' obligatoire!", vbInformation, "Recherche"
Exit Sub
Else
Me.Range("D4").ClearContents
End If
If (Not IsEmpty(Me.Range("C6")) And IsEmpty(Me.Range("C8"))) Or _
(IsEmpty(Me.Range("C6")) And Not IsEmpty(Me.Range("C8"))) Then
Application.ScreenUpdating = True
With Me.Range("D6")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
With Me.Range("D8")
.Value = "*"
.Font.ColorIndex = 3
.Font.Bold = True
End With
Me.Range("C12") = 0
Application.ScreenUpdating = False
MsgBox "champs 'ville/code postal' obligatoires!", vbInformation, "Recherche"
Exit Sub
Else
Me.Range("D6").ClearContents
Me.Range("D8").ClearContents
End If
If IsEmpty(source) Then SetGlobales
nb = 0
If IsEmpty(Me.Range("C6")) Then
For i = 2 To UBound(source, 1)
If Trim(source(i, 12)) = CStr(Me.Range("C4")) And Trim(source(i, 5)) = CStr(Me.Range("C10")) Then
nb = nb + 1
For j = 1 To UBound(source, 2)
Me.Cells(16 + nb, j + 1) = source(i, j)
Next j
End If
Next i
Else
For i = 2 To UBound(source, 1)
If Trim(source(i, 12)) = CStr(Me.Range("C4")) And Trim(source(i, 11)) = CStr(Me.Range("C6")) And _
Trim(source(i, 13)) = CStr(Me.Range("C8")) And Trim(source(i, 5)) = CStr(Me.Range("C10")) Then
nb = nb + 1
For j = 1 To UBound(source, 2)
Me.Cells(16 + nb, j + 1) = source(i, j)
Next j
End If
Next i
End If
Me.Range("C12") = nb
If nb <> 0 Then
For i = 1 To UBound(source, 2)
Me.Cells(16, i + 1) = source(1, i)
Next i
Set rng = Me.Range(Me.Cells(16, 2), Me.Cells(16, 2 + UBound(source, 2) - 1))
With rng.Rows(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
rng.Rows(1).Font.Bold = True
Set rng = Me.Range(Me.Cells(16, 2), Me.Cells(16 + nb, 2 + UBound(source, 2) - 1))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Me.Cells.EntireColumn.AutoFit
End If
Me.Cells.EntireRow.AutoFit
Application.ScreenUpdating = True
Exit Sub
errHdl:
MsgBox "Erreur: feuille 'lancement' (procédure 'FilterButton_Click')", vbExclamation, "Erreur"
Application.ScreenUpdating = True
End Sub
Private Function FindStr(s1 As String, s2 As String) As Boolean
Dim i As Integer
Dim t() As String
t = Split(s1, ",")
For i = 0 To UBound(t)
If t(i) = s2 Then
FindStr = True
Exit Function
End If
Next i
FindStr = False
End Function
