Code VBA fait crashé d'Excel
L
Salutation
J'ai un problème avec un programme vba qui à pour but de repéré les cases d'entrée d'un tableau sur une page Excel, ensuite inséré une valeur et récupérer le nom de la colonne mais le code fait crash mon Excel, je ne comprend pas ou est le problème et je me tourne vers vous. J'ai déjà tester une version de se code plus simple, sans le retour du nom de colonne, et qui fonctionnait. Je suis sur Windows 10 avec un excel version 2016.
Sub remplissage1()
Dim finp As Double
Dim nb As Long, i As Double, j As Long, Finl As Long
Dim nb2 As Long, i2 As Double, j2 As Long, Finl2 As Long, Finp2 As Long
Dim X As Boolean
Dim y As Integer
Dim k As Double
Dim l As Double
nb2 = 1 'Conteur Data
j = 1 'conteur de colone
i = 1 'conteur de ligne
finp = 33 ' profondeur/ligne
Finl = 43 'longueur/colonne
Sheets("test1").Select 'Feuille Selectionné
Do While i <= finp
nb = 0
For j = 1 To Finl Step 1
X = False: On Error Resume Next 'conteur de choix multiple
X = Cells(i, j).Validation.InCellDropdown 'conteur de choix multiple
y = IIf(X = True, 11111, 0) 'conteur de choix multiple
'Debut de la selection
Sheets("test1").Cells(i, j).Select
If Not y = 11111 And Not Left(Cells(i, j).Formula, 1) = "=" And Not Cells(i, j).MergeCells And IsNumeric(Cells(i, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
Sheets("test").Cells(2, nb2) = Sheets("test1").Cells(i, j)
Sheets("test").Cells(3, nb2) = i
Sheets("test").Cells(4, nb2) = j
Sheets("test1").Cells(i, j) = Sheets("test").Cells(1, nb2)
nb2 = nb2 + 1 ' incrementation conteur de variable d'entrée
l = 1
k = 1
If Not i = k Then
Do While l = 1
Cells(i - k, j).Select
If WorksheetFunction.IsText(Cells(i, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
Sheets("test").Cells(5, nb2) = Sheets("test1").Cells(i - k, j)
l = 0
Else
k = k + 1
'MsgBox k
End If
Loop
End If
End If
Next
i = i + 1
Loop
'MsgBox i
'MsgBox j
'Cells(i, j).Select
End SubBonjour,
Sans fichier pour tester > c'est bien embêtant ...
i As Double ( double pour un nombre à virgule flottante ) > devrait être "Integer" ou "Long" si sa valeur peut être plus grande que 32767 ...
i2 As Double n'est pas utilisé ...
j2 as Long n'est pas utilisé ...
i2 et j2 sont aussi des adresses de cellule "ATTENTION" à ce genre de conflit ...
ric
L
Tu avais raison Ric, il suffisait d'exécuter le code pas à pas et à partir de là , j'ai pue réécrire mon code que voici :
Sub remplissage1()
Dim finp As Double
Dim nb As Long, i As Double, j As Long, Finl As Long
Dim nb2 As Long
Dim X As Boolean
Dim y As Integer
Dim k As Double
Dim l As Double
nb2 = 1 'Conteur Data
j = 6 'conteur de colone
i = 13 'conteur de ligne
finp = 14 ' profondeur/ligne
Finl = 43 'longueur/colonne
nb = j
Sheets("test1").Select 'Feuille Selectionné
Do While i <= finp
For j = nb To Finl Step 1
X = False: On Error Resume Next 'conteur de choix multiple
X = Cells(i, j).Validation.InCellDropdown 'conteur de choix multiple
y = IIf(X = True, 11111, 0) 'conteur de choix multiple
'Debut de la selection
Sheets("test1").Cells(i, j).Select
If Not y = 11111 And Not Left(Cells(i, j).Formula, 1) = "=" And Not Cells(i, j).MergeCells And IsNumeric(Cells(i, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
Sheets("test").Cells(2, nb2) = Sheets("test1").Cells(i, j)
Sheets("test").Cells(3, nb2) = i
Sheets("test").Cells(4, nb2) = j
Sheets("test1").Cells(i, j) = Sheets("test").Cells(1, nb2)
nb2 = nb2 + 1 ' incrementation conteur de variable d'entrée
l = 1
k = 1
Do While l = 1 'Récupération du titre de la colonne
If Not i = k And i > 1 Then
Cells(i - k, j).Select
If WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous Then
Sheets("test").Cells(5, nb2) = Sheets("test1").Cells(i - k, j) ' Bordure sup
l = 0
ElseIf WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Not i = k Then
Sheets("test").Cells(5, nb2) = Sheets("test1").Cells(i - k, j) 'contoure
l = 0
ElseIf WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
Sheets("test").Cells(6, nb2) = Sheets("test1").Cells(i - k, j) 'bordure inf
k = k + 1
Else
k = k + 1
'MsgBox k
End If
Else
l = 0
End If
Loop
Sheets("test").Cells(7, nb2) = Sheets("test1").Cells(i, 2) 'Récupération du titre de ligne
l = 1
k = 1
Do While l = 1 'Récupération du titre de la catégorie
If Not i = k And i > 1 Then
Cells(i - k, j).Select
If Cells(i - k, j).MergeCells And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Not i = k And Cells(i - k + 1, j) = "" And Cells(i - k - 1, j) = "" Then
Sheets("test").Cells(8, nb2) = Sheets("test1").Cells(i - k, j).Value 'Sheets("test").Cells(10, 1) = Sheets("test1").Cells(7, 2).Value
l = 0
Else
k = k + 1
'MsgBox k
End If
Else
l = 0
End If
Loop
End If
Next
i = i + 1
Loop
MsgBox i
MsgBox j
Cells(i, j).Select
End Sub