Correction macro

Le 03/02/2020 à 16:12

Bonjour à tous je sollicite s'il vous plait votre aide sur cette macro car en compilant il me renvoie le message: "Erreur 1004 définie par l'application ou par l'objet et quand je clique sur débogage il souligne en jaune la ligne : f3.Cells(1, Col) = f3.Cells(n, "A"):

Sub Reorganisation()

Dim DerLig_f1 As Long, DerLig_f3 As Long, DerCol_f1 As Long, DerCol_f2 As Long, DerCol_f3 As Long

Dim i As Long, j As Long, k As Long, m As Long, n As Long, NbVal As Long, NbArt As Long, Col As Long

Dim Num As String

Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet

Dim P As Double, P2 As Double

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Deb = Time

Set f1 = Sheets("Feuil1")

Set f2 = Sheets("Feuil2")

Set f3 = Sheets("Feuil3")

DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row

DerCol_f1 = f1.[XFD1].End(xlToLeft).Column

DerCol_f2 = DerCol_f1

f2.Cells.ClearContents

f3.Cells.ClearContents

'On travaille sur la feuille "Feuil2" en faisant une copie de la feuille 1

f1.Range(Cells(1, "A"), Cells(DerLig_f1, DerCol_f1)).Copy f2.Range("A1")

f2.Select

'format des articles

f2.Range("A2:A" & DerLig_f1).NumberFormat = "000000000"

f3.Range("A1").NumberFormat = "000000000"

'tri par article

Range(Cells(2, "A"), Cells(DerLig_f1, DerCol_f1)).Sort [A1], 1

'Analyse et traitement

For i = 2 To DerLig_f1 - 1

If f2.Cells(i, "A") = f2.Cells(i + 1, "A") Then

Art = f2.Cells(i, "A")

NbArt = Application.WorksheetFunction.CountIf(f2.Range(Cells(2, "A"), Cells(f2.Range("A" & Rows.Count).End(xlUp).Row, "A")), Art)

If NbArt > 1 Then 'S'il y a plusieurs fois le même article

Num = ""

DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row

Lig = 3 'N° de la première ligne de la feuille "Feuil3" destinée à recevoir les tranches et les prix

For j = 0 To NbArt - 1

Num = Num & "_" & Cells(i + j, "B") 'récupération des numéros d'article

Next j

f3.[A1] = Art 'Recopie de l'article dans feuille "Feuil3"

f3.[B1] = Mid(Num, 2, Len(Num) - 1) 'Recopie des numéros d'article dans feuille "Feuil3"

For k = i To i + NbArt - 1

DerCol_f2 = f2.Cells(k, "A").End(xlToRight).Column

For l = 3 To DerCol_f2 Step 2 'on récupère les tranches et les prix et on les recopie en colonnes dans feuille "Feuil3"

f3.Cells(Lig, "A") = f2.Cells(k, l)

f3.Cells(Lig, "B") = f2.Cells(k, l + 1)

Lig = Lig + 1

Next l

Next k

f3.Select

DerLig_f3 = f3.[A3].End(xlDown).Row

'On fait un tri par tranches ascendantes et prix descendants dans feuille "Feuil3"

f3.Range("A3:B" & DerLig_f3).Select

ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Add Key:=f3.Range("A3:A" & DerLig_f3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Add Key:=f3.Range("B3:B" & DerLig_f3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Feuil3").Sort

.SetRange f3.Range("A3:B" & DerLig_f3)

.Header = xlGuess

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

'On supprime les tranches en double avec le prix le plus bas

For m = DerLig_f3 To 3 Step -1

If f3.Cells(m, "A") = f3.Cells(m - 1, "A") Then f3.Rows(m).Delete

Next m

'Reconstitution de la nouvelle ligne en remplacement des doublons

NbVal = f3.[A3].End(xlDown).Row - 2

Col = 3

For n = 3 To NbVal + 2

f3.Cells(1, Col) = f3.Cells(n, "A")

f3.Cells(1, Col + 1) = f3.Cells(n, "B")

Col = Col + 2

Next n

'on recopie la nouvelle ligne dans la feuille "Feuil2"

f3.Rows(1).Copy f2.Rows(i)

f3.Cells.ClearContents

'Suppression des lignes comportant le même article

f2.Select

Rows(i + 1 & ":" & i + NbArt - 1).Delete

End If

Next i

'ajout des titres dans la feuille "Feuil2"

DerCol_f2 = f2.Range("A1").SpecialCells(xlCellTypeLastCell).Column

f2.[A1] = "Article"

f2.[B1] = "Numéro"

Num = 1

For i = 3 To DerCol_f2 Step 2

f2.Cells(1, i) = "Tranche " & Num

f2.Cells(1, i + 1) = "Prix " & Num

Num = Num + 1

Next i

Set f1 = Nothing

Set f2 = Nothing

Set f3 = Nothing

MsgBox "Deb: " & Deb & Chr(10) & "Fin: " & Time

End Sub

Le 03/02/2020 à 16:17

Bonjour,

Merci d'utiliser les "balises" code la prochaine fois... : </>

Lorsque tu arrives à cette ligne de code :

f3.Cells(1, Col) = f3.Cells(n, "A")

que valent les variables Col et n ?

Pour cela, il convient d'utiliser la fenêtre "variables locales" (Dans VBE : Menu Affichage)

Le 03/02/2020 à 16:23

Col vaut 16385 et n vaut 8194.

Merci

Le 03/02/2020 à 19:30

Voici le code entre balise. Merci

Sub Reorganisation()
Dim DerLig_f1 As Long, DerLig_f3 As Long, DerCol_f1 As Long, DerCol_f2 As Long, DerCol_f3 As Long
Dim i As Long, j As Long, k As Long, m As Long, n As Long, NbVal As Long, NbArt As Long, Col As Long
Dim Num As String
Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
Dim P As Double, P2 As Double

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Deb = Time
Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")
Set f3 = Sheets("Feuil3")
DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
DerCol_f1 = f1.[XFD1].End(xlToLeft).Column
DerCol_f2 = DerCol_f1

f2.Cells.ClearContents
f3.Cells.ClearContents

'On travaille sur la feuille "Feuil2" en faisant une copie de la feuille 1
f1.Range(Cells(1, "A"), Cells(DerLig_f1, DerCol_f1)).Copy f2.Range("A1")

f2.Select
'format des articles
f2.Range("A2:A" & DerLig_f1).NumberFormat = "000000000"
f3.Range("A1").NumberFormat = "000000000"

'tri par article
Range(Cells(2, "A"), Cells(DerLig_f1, DerCol_f1)).Sort [A1], 1

'Analyse et traitement
For i = 2 To DerLig_f1 - 1
If f2.Cells(i, "A") = f2.Cells(i + 1, "A") Then
Art = f2.Cells(i, "A")
NbArt = Application.WorksheetFunction.CountIf(f2.Range(Cells(2, "A"), Cells(f2.Range("A" & Rows.Count).End(xlUp).Row, "A")), Art)
If NbArt > 1 Then 'S'il y a plusieurs fois le même article
Num = ""
DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
Lig = 3 'N° de la première ligne de la feuille "Feuil3" destinée à recevoir les tranches et les prix
For j = 0 To NbArt - 1
Num = Num & "_" & Cells(i + j, "B") 'récupération des numéros d'article
Next j
f3.[A1] = Art 'Recopie de l'article dans feuille "Feuil3"
f3.[B1] = Mid(Num, 2, Len(Num) - 1) 'Recopie des numéros d'article dans feuille "Feuil3"
For k = i To i + NbArt - 1
DerCol_f2 = f2.Cells(k, "A").End(xlToRight).Column
For l = 3 To DerCol_f2 Step 2 'on récupère les tranches et les prix et on les recopie en colonnes dans feuille "Feuil3"
f3.Cells(Lig, "A") = f2.Cells(k, l)
f3.Cells(Lig, "B") = f2.Cells(k, l + 1)
Lig = Lig + 1
Next l
Next k

f3.Select
DerLig_f3 = f3.[A3].End(xlDown).Row
'On fait un tri par tranches ascendantes et prix descendants dans feuille "Feuil3"
f3.Range("A3:B" & DerLig_f3).Select
ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Add Key:=f3.Range("A3:A" & DerLig_f3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Feuil3").Sort.SortFields.Add Key:=f3.Range("B3:B" & DerLig_f3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil3").Sort
.SetRange f3.Range("A3:B" & DerLig_f3)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'On supprime les tranches en double avec le prix le plus bas
For m = DerLig_f3 To 3 Step -1
If f3.Cells(m, "A") = f3.Cells(m - 1, "A") Then f3.Rows(m).Delete
Next m

'Reconstitution de la nouvelle ligne en remplacement des doublons
NbVal = f3.[A3].End(xlDown).Row - 2
Col = 3
For n = 3 To NbVal + 2
f3.Cells(1, Col) = f3.Cells(n, "A")
f3.Cells(1, Col + 1) = f3.Cells(n, "B")
Col = Col + 2
Next n

'on recopie la nouvelle ligne dans la feuille "Feuil2"
f3.Rows(1).Copy f2.Rows(i)
f3.Cells.ClearContents

'Suppression des lignes comportant le même article
f2.Select
Rows(i + 1 & ":" & i + NbArt - 1).Delete
End If
End If
Next i

'ajout des titres dans la feuille "Feuil2"
DerCol_f2 = f2.Range("A1").SpecialCells(xlCellTypeLastCell).Column
f2.[A1] = "Article"
f2.[B1] = "Numéro"
Num = 1
For i = 3 To DerCol_f2 Step 2
f2.Cells(1, i) = "Tranche " & Num
f2.Cells(1, i + 1) = "Prix " & Num
Num = Num + 1
Next i

Set f1 = Nothing
Set f2 = Nothing
Set f3 = Nothing
MsgBox "Deb: " & Deb & Chr(10) & "Fin: " & Time
End Sub

Le 03/02/2020 à 20:16

Bonjour,

Quel est le nombre total de colonnes dans une feuille Excel ? 16.384

Si Col a effectivement une valeur de 16.385, il y a souci…

Cdlt.

Le 03/02/2020 à 20:21

Vous avez raison mais je sais pas qu'est ce qui ne va pas dans ce code car je débute en vba.

Merci beaucoup

Rechercher des sujets similaires à "correction macro"