Re : Erreur d'exécution 6 dépassement de capacité
Mon code est assez conséquent mais le voila:
Merci d'avance sur vos réponses je jette un coup d'oeil 🙂
code:
Dim bd, f
Dim TAbTemp As Variant
Dim bd2, f2
Dim TAbTemp2 As Variant
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set d = CreateObject("Scripting.Dictionary")
Set bd = f.Range("D2:M" & f.[M65000].End(xlUp).Row)
For i = 1 To bd.Rows.Count
If bd.Cells(i, 1) <> "" Then d(bd.Cells(i, 1).Value) = ""
Next i
temp = d.keys
Me.ComboBox1.List = temp
Me.ListBox1.List = bd.Value
For K = 1 To 9: Me("label" & K).Caption = f.Cells(1, K): Next K
Dim L As Long
With Sheets("bd")
L = .Range("A65536").End(xlUp).Row
TAbTemp = .Range(.Cells(1, 1), .Cells(L, 3)).Value
End With
'------------------------------------------------------------------
Set f2 = Sheets("BD2")
Set d = CreateObject("Scripting.Dictionary")
Set bd2 = f2.Range("D2:M" & f.[M65000].End(xlUp).Row)
For i = 1 To bd2.Rows.Count
If bd2.Cells(i, 1) <> "" Then d(bd2.Cells(i, 1).Value) = ""
Next i
temp = d.keys
Me.ComboBox2.List = temp
Me.ListBox2.List = bd2.Value
Dim M As Long
With Sheets("bd2")
M = .Range("A65536").End(xlUp).Row
TAbTemp2 = .Range(.Cells(1, 1), .Cells(M, 3)).Value
End With
'---------------------------------------------------------------------------------------
K = 0
With Sheets("BD2")
For i = 2 To .[A65000].End(xlUp).Row
If .Cells(i, 13) < 1 Then
Me.ListBox3.AddItem
Me.ListBox3.List(K, 0) = .Cells(i, 4)
Me.ListBox3.List(K, 1) = .Cells(i, 5)
Me.ListBox3.List(K, 2) = .Cells(i, 6)
K = K + 1
End If
Next i
End With
'-------------------------------------------------------------------------------------------
K = 0
With Sheets("BD")
For i = 2 To .[A65000].End(xlUp).Row
datduJour = Date
If .Cells(i, 10) < Format(datduJour, "dd/mm/yyyy") Then 'Cells(1, 16)
Me.ListBox4.AddItem
Me.ListBox4.List(K, 0) = .Cells(i, 4)
Me.ListBox4.List(K, 1) = .Cells(i, 5)
Me.ListBox4.List(K, 2) = .Cells(i, 6)
Me.ListBox4.List(K, 3) = .Cells(i, 7)
Me.ListBox4.List(K, 4) = .Cells(i, 8)
Me.ListBox4.List(K, 5) = .Cells(i, 9)
Me.ListBox4.List(K, 6) = .Cells(i, 10)
Me.ListBox4.List(K, 7) = .Cells(i, 11)
Me.ListBox4.List(K, 9) = .Cells(i, 13)
K = K + 1
End If
Next i
End With
'Charger manuellement le combobox
secteur.AddItem "Bacteriologie"
secteur.AddItem "Virologie"
secteur.AddItem "LRS"
secteur.AddItem "Sero-Viro"
secteur2.AddItem "Bacteriologie"
secteur2.AddItem "Virologie"
secteur2.AddItem "LRS"
secteur2.AddItem "Sero-Viro"
End Sub
Private Sub ComboBox1_Click()
Dim a()
N = Application.CountIf(Application.Index(bd, , 1), Me.ComboBox1)
ReDim a(1 To N, 1 To bd.Columns.Count)
ligne = 0
For i = 1 To bd.Rows.Count
If bd.Cells(i, 1) = Me.ComboBox1 Then
ligne = ligne + 1
For K = 1 To bd.Columns.Count: a(ligne, K) = bd.Cells(i, K): Next K
End If
Next i
Me.ListBox1.List = a()
Me.TextBox1.Value = Me.ComboBox1.Text
End Sub
Private Sub secteur_Change()
Dim TabSansDoublon As New Collection
Dim L As Long
On Error Resume Next
For L = 1 To UBound(TAbTemp, 1)
If TAbTemp(L, 1) = secteur.Text Then
TabSansDoublon.Add TAbTemp(L, 2), CStr(TAbTemp(L, 2))
End If
Next L
On Error GoTo 0
fournisseur.Clear
For L = 1 To TabSansDoublon.Count
fournisseur.AddItem TabSansDoublon(L)
Next L
ComboBox1.Clear
End Sub
Private Sub fournisseur_Change()
Dim TabSansDoublon As New Collection
Dim L As Long
On Error Resume Next
For L = 1 To UBound(TAbTemp, 1)
If TAbTemp(L, 2) = fournisseur.Text Then
TabSansDoublon.Add TAbTemp(L, 3), CStr(TAbTemp(L, 3))
End If
Next L
On Error GoTo 0
ComboBox1.Clear
For L = 1 To TabSansDoublon.Count
ComboBox1.AddItem TabSansDoublon(L)
Next L
End Sub
Private Sub CommandButton1_Click()
Sheets("BD").Range("a65536").End(xlUp).Offset(1, 0) = Me.secteur.Value
Sheets("BD").Range("b65536").End(xlUp).Offset(1, 0) = Me.fournisseur.Value
Sheets("BD").Range("c65536").End(xlUp).Offset(1, 0) = Me.ComboBox1.Value
Sheets("BD").Range("d65536").End(xlUp).Offset(1, 0) = Me.TextBox1.Value
Sheets("BD").Range("e65536").End(xlUp).Offset(1, 0) = Me.TextBox2.Value
Sheets("BD").Range("f65536").End(xlUp).Offset(1, 0) = Me.TextBox3.Value
Sheets("BD").Range("g65536").End(xlUp).Offset(1, 0) = Me.TextBox4.Value
Sheets("BD").Range("h65536").End(xlUp).Offset(1, 0) = Me.TextBox5.Value
Sheets("BD").Range("i65536").End(xlUp).Offset(1, 0) = Me.TextBox6.Value
Sheets("BD").Range("j65536").End(xlUp).Offset(1, 0) = Me.TextBox7.Value
Sheets("BD").Range("k65536").End(xlUp).Offset(1, 0) = Me.TextBox8.Value
Sheets("BD").Range("l65536").End(xlUp).Offset(1, 0) = Me.TextBox9.Value
Sheets("BD").Range("m65536").End(xlUp).Offset(1, 0) = Me.TextBox10.Value
For i = 1 To 10
Me.Controls("TextBox" & i).Value = "x"
Next i
MsgBox "Votre saisie est réussie", vbOKOnly + vbInformation, "Saisie réussie"
Unload Recherche
Recherche.Show
End Sub
Private Sub ListBox1_Change()
TextBox2 = ListBox1.List(ListBox1.ListIndex, 1)
TextBox3 = ListBox1.List(ListBox1.ListIndex, 2)
TextBox4 = ListBox1.List(ListBox1.ListIndex, 3)
TextBox5 = ListBox1.List(ListBox1.ListIndex, 4)
TextBox9 = ListBox1.List(ListBox1.ListIndex, 8)
TextBox6 = ListBox1.List(ListBox1.ListIndex, 5)
TextBox7 = ListBox1.List(ListBox1.ListIndex, 6)
TextBox8 = ListBox1.List(ListBox1.ListIndex, 7)
TextBox10 = ListBox1.List(ListBox1.ListIndex, 9)
End Sub
Private Sub CommandButton2_Click()
Sheets("BD").Cells(TextBox9, 9).Value = Me.TextBox6.Text
Sheets("BD").Cells(TextBox9, 10).Value = Me.TextBox7.Text
Sheets("BD").Cells(TextBox9, 11).Value = Me.TextBox8.Text
Sheets("BD").Cells(TextBox9, 13).Value = Me.TextBox10.Text
ListBox1.List(ListBox1.ListIndex, 5) = TextBox6.Text
ListBox1.List(ListBox1.ListIndex, 6) = TextBox7.Text
ListBox1.List(ListBox1.ListIndex, 7) = TextBox8.Text
ListBox1.List(ListBox1.ListIndex, 9) = TextBox10.Text
End Sub
Private Sub secteur2_Change()
Dim TabSansDoublon As New Collection
Dim L As Long
On Error Resume Next
For L = 1 To UBound(TAbTemp2, 1)
If TAbTemp2(L, 1) = secteur2.Text Then
TabSansDoublon.Add TAbTemp2(L, 2), CStr(TAbTemp2(L, 2))
End If
Next L
On Error GoTo 0
fournisseur2.Clear
For L = 1 To TabSansDoublon.Count
fournisseur2.AddItem TabSansDoublon(L)
Next L
ComboBox2.Clear
End Sub
Private Sub fournisseur2_Change()
Dim TabSansDoublon As New Collection
Dim L As Long
On Error Resume Next
For L = 1 To UBound(TAbTemp, 1)
If TAbTemp2(L, 2) = fournisseur2.Text Then
TabSansDoublon.Add TAbTemp2(L, 3), CStr(TAbTemp2(L, 3))
End If
Next L
On Error GoTo 0
ComboBox2.Clear
For L = 1 To TabSansDoublon.Count
ComboBox2.AddItem TabSansDoublon(L)
Next L
End Sub
Private Sub ComboBox2_Click()
Dim a() As Double
N = Application.CountIf(Application.Index(bd2, , 1), Me.ComboBox2)
ReDim a(1 To N, 1 To bd2.Columns.Count)
ligne = 0
For i = 1 To bd2.Rows.Count
If bd2.Cells(i, 1) = Me.ComboBox2 Then
ligne = ligne + 1
For K = 1 To bd2.Columns.Count: a(ligne, K) = bd2.Cells(i, K): Next K
End If
Next i
Me.ListBox2.List = a()
Me.TextBox16.Value = Me.ComboBox2.Text
End Sub
Private Sub ListBox2_change()
TextBox17 = ListBox2.List(ListBox2.ListIndex, 7)
TextBox11 = ListBox2.List(ListBox2.ListIndex, 8)
End Sub
Private Sub CommandButton3_Click()
Sheets("BD2").Cells(TextBox11, 11).Value = Me.TextBox17.Text
ListBox2.List(ListBox2.ListIndex, 7) = TextBox17.Text
End Sub
Private Sub CommandButton4_Click()
MsgBox "Liste des articles à commander actualisée", vbOKOnly + vbInformation, "Saisie réussie"
Unload Recherche
Recherche.Show
End Sub
Private Sub CommandButton5_Click()
Dim Tableau() As Variant
Dim i As Integer
Dim j As Byte
Application.ScreenUpdating = False
Workbooks.Add 'création d'un nouveau classeur temporaire
Tableau() = ListBox3.List
j = ListBox3.ColumnCount
i = ListBox3.ListCount
Range("A1:" & Cells(i, j).Address) = Tableau()
'option pour adapter la largeur des colonnes à la taille des données
ActiveSheet.Range("A1:" & Cells(i, j).Address).EntireColumn.AutoFit
ActiveWorkbook.PrintOut 'impression
ActiveWorkbook.Close False 'suppression du classeur temporaire
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton6_Click()
ActiveWorkbook.FollowHyperlink Address:="http://septantesix3/MAN_QUAL/Manuel_New/Chapitre_6/listes/produits/Commandes/SAP_Login.idc"
End Sub
Private Sub CommandButton7_Click()
MsgBox "Liste des réactifs périmés a été actualisée", vbOKOnly + vbInformation, "Saisie réussie"
Unload Recherche
Recherche.Show
End Sub
Private Sub CommandButton9_Click()
ActiveWorkbook.FollowHyperlink Address:="G:\Microbiologie\LMM\LMM\Qualité\Gestion stocks\BAC_MOLECULAIRE\03_07_00_06_004_F002_TRACABILITE MICROBIOLOGIE MOLECULAIRE Pièce ADNARN Free.xls"
Unload Recherche
End Sub
Private Sub CommandButton10_Click()
ActiveWorkbook.FollowHyperlink Address:="G:\Microbiologie\LMM\LMM\Qualité\Gestion stocks\BAC_MOLECULAIRE\03_07_00_06_004_F003_TRACABILITE MICROBIOLOGIE MOLECULAIRE Extraction & clivage PFGE.xls"
Unload Recherche
End Sub
Private Sub CommandButton8_Click()
ActiveWorkbook.FollowHyperlink Address:="G:\Microbiologie\LMM\LMM\Qualité\Gestion stocks\BAC_MOLECULAIRE\03_07_00_06_004_F004_TRACABILITE MATERIEL MICROBIOLOGIE MOLECULAIRE post_PCR.xls"
Unload Recherche
End Sub
Private Sub CommandButton11_Click()
ActiveWorkbook.FollowHyperlink Address:="G:\Microbiologie\LMM\LMM\Qualité\Gestion stocks\BAC_MOLECULAIRE\03_07_01_09_001_F005_Récapitulatif traçabilité bactériologie moléculaire.xls"
Unload Recherche
End Sub
