Code erreur exécution 6 'dépassement de capacité'

peternewman007

XLDnaute Nouveau
Bonjour à tous,

J'ai un petit souci (code erreur 6) lorsque je clique sur la case à gauche de A et au-dessus du 1 (j'ignore son nom).
Le déboggeur me surligne la ligne que moi j'ai mis en rouge.
Voici mon code :
' Code permettant le choix dans les combobox avec une recherche intuitive sur le début du mot
If Not Intersect([Choix_Fonctions], target) Is Nothing And target.Count = 1 Then
Fonctions = Application.Transpose(Sheets("BD").Range("Fonctions").Value)
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In Fonctions
If c <> "" Then d1(c) = ""
Next c
TblFonctions = d1.keys
Me.ComboBox1.List = TblFonctions
Me.ComboBox1.Height = target.Height + 3
Me.ComboBox1.Width = target.Width
Me.ComboBox1.Top = target.Top
Me.ComboBox1.Left = target.Left
Me.ComboBox1 = target
Me.ComboBox1.Visible = True
Me.ComboBox1.Activate
'If Target <> "" Then SendKeys "{esc}"
Else
Me.ComboBox1.Visible = False
End If
'----
If Not Intersect([Choix_Chantiers], target) Is Nothing And target.Count = 1 Then
Condition = UCase(target.Offset(, -1))
If Condition = "" Then Exit Sub
Chantiers = Application.Transpose(Sheets("BD").Range("Chantiers").Value)
Fonctions = Application.Transpose(Sheets("BD").Range("Fonctions").Value)
ReDim TblChantiers(1 To UBound(Fonctions))
Set d1 = CreateObject("Scripting.Dictionary")
For i = LBound(Chantiers) To UBound(Chantiers)
If Fonctions(i) = Condition Then d1(Chantiers(i)) = ""
Next i
TblChantiers = d1.keys
Me.ComboBox2.List = TblChantiers
Me.ComboBox2.Height = target.Height + 3
Me.ComboBox2.Width = target.Width
Me.ComboBox2.Top = target.Top
Me.ComboBox2.Left = target.Left
Me.ComboBox2 = target
Me.ComboBox2.Visible = True
Me.ComboBox2.Activate
'If Target <> "" Then SendKeys "{esc}"
'Me.ComboBox2.DropDown ' ouverture automatique au clic dans la cellule (optionel)
Else
Me.ComboBox2.Visible = False
End If
'---
If Not Intersect([Choix_Positions], target) Is Nothing And target.Count = 1 Then
Condition1 = UCase(target.Offset(, -2))
Condition2 = UCase(target.Offset(, -1))
If Condition1 = "" Or Condition2 = "" Then Exit Sub
Chantiers = Application.Transpose(Sheets("BD").Range("Chantiers").Value)
Fonctions = Application.Transpose(Sheets("BD").Range("Fonctions").Value)
Positions = Application.Transpose(Sheets("BD").Range("Positions").Value)
ligne = 0
ReDim TblPositions(1 To UBound(Fonctions))
For i = LBound(Chantiers) To UBound(Chantiers)
If Fonctions(i) = Condition1 And Chantiers(i) = Condition2 Then
ligne = ligne + 1: TblPositions(ligne) = Positions(i)
End If
Next i
If TblPositions(1) <> "" Then
ReDim Preserve TblPositions(1 To ligne)
Me.ComboBox3.List = TblPositions
Me.ComboBox3.Height = target.Height + 3
Me.ComboBox3.Width = target.Width
Me.ComboBox3.Top = target.Top
Me.ComboBox3.Left = target.Left
Me.ComboBox3 = target
Me.ComboBox3.Visible = True
Me.ComboBox3.Activate
'If Target <> "" Then SendKeys "{esc}"
'Me.ComboBox1.DropDown ' ouverture automatique au clic dans la cellule (optionel)
Else
target = "Néant"
End If
Else
Me.ComboBox3.Visible = False
End If
End Sub
Private Sub ComboBox1_Change()
If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, TblFonctions, 0)) Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In TblFonctions
If UCase(c) Like tmp Then d1(c) = ""
Next c
Me.ComboBox1.List = Filter(TblFonctions, Me.ComboBox1.Text, True, vbTextCompare)
Me.ComboBox1.DropDown
End If
ActiveCell.Value = Me.ComboBox1 ': ActiveCell.Offset(, 1) = "": ActiveCell.Offset(, 2) = ""
End Sub
Private Sub ComboBox2_Change()
If Me.ComboBox2 <> "" And IsError(Application.Match(Me.ComboBox2, TblChantiers, 0)) Then
Set d1 = CreateObject("Scripting.Dictionary")
tmp = UCase(Me.ComboBox2) & "*"
For Each c In TblChantiers
If UCase(c) Like tmp Then d1(c) = ""
Next c
Me.ComboBox2.List = Filter(TblChantiers, Me.ComboBox2.Text, True, vbTextCompare)
Me.ComboBox2.DropDown
End If
ActiveCell.Value = Me.ComboBox2 ': ActiveCell.Offset(, 1) = ""
End Sub
Private Sub ComboBox3_Change()
If Me.ComboBox3 <> "" And IsError(Application.Match(Me.ComboBox3, TblPositions, 0)) Then
Set d1 = CreateObject("Scripting.Dictionary")
tmp = UCase(Me.ComboBox3) & "*"
For Each c In TblPositions
If UCase(c) Like tmp Then d1(c) = ""
Next c
Me.ComboBox3.List = Filter(TblPositions, Me.ComboBox3.Text, True, vbTextCompare)
Me.ComboBox3.DropDown
End If
ActiveCell.Value = Me.ComboBox3
End Sub
Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.ComboBox2.List = TblChantiers
Me.ComboBox2.Activate
Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.ComboBox1.List = TblFonctions
Me.ComboBox1.Activate
Me.ComboBox1.DropDown
End Sub
Private Sub ComboBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.ComboBox3.List = TblPositions
Me.ComboBox3.Activate
Me.ComboBox3.DropDown
End Sub
Private Sub ComboBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 9 Then
If Shift = 1 Then
ActiveCell.Offset(, -1).Select
Else
ActiveCell.Offset(, 1).Select
End If
End If
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 9 Then
If Shift = 1 Then
ActiveCell.Offset(, -1).Select
Else
ActiveCell.Offset(, 1).Select
End If
End If
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 9 Then
If Shift = 1 Then
ActiveCell.Offset(, -1).Select
Else
ActiveCell.Offset(, 1).Select
End If
End If
End Sub

Comment pourrais-je le résoudre ou interdire l'accès à cette case?

MErci d'avance,

Peter
 

phlaurent55

Nous a quittés en 2020
Repose en paix
Re : Code erreur exécution 6 'dépassement de capacité'

bonjour Peter,

on peut résoudre en mettant ceci avant la "ligne en rouge" mais ce n'est pas la solution miracle
On Error Resume Next

pour empêcher la sélection entière il suffit de décocher les titres

111.jpg

119.jpg
à+
Philippe
 

Pièces jointes

  • 111.jpg
    111.jpg
    87.1 KB · Affichages: 69
  • 111.jpg
    111.jpg
    87.1 KB · Affichages: 81
  • 119.jpg
    119.jpg
    83.6 KB · Affichages: 99
  • 119.jpg
    119.jpg
    83.6 KB · Affichages: 98

peternewman007

XLDnaute Nouveau
Re : Code erreur exécution 6 'dépassement de capacité'

Bonjour phlaurent55,

La solution de On Error Resume Next avait l'air de fonctionner mais le fichier plante avoir avoir sélectionné cette fameuse case au-dessus à gauche.

Comment pourrais-je résoudre le souci?

Bonjour Efgé,

Le countLarge ne change malheureusement rien :(

Peter
 

Efgé

XLDnaute Barbatruc
Re : Code erreur exécution 6 'dépassement de capacité'

Re
Si, si...

Change ta ligne en rouge par

If Not Intersect([Choix_Fonctions], target) Is Nothing And target.CountLarge = 1 Then

Cordialement

EDIT

Il faur modifier tous tes .Count par .CounLarge, évidemment :rolleyes:
 
Dernière édition:

Discussions similaires

Réponses
5
Affichages
365

Statistiques des forums

Discussions
311 724
Messages
2 081 938
Membres
101 844
dernier inscrit
pktla