Bug données Macro

nomitse

XLDnaute Nouveau
Bonjour, J'ai créé une macro qui me permet de créer plusieurs onglets en fonction d'une liste et d'y coller une partie de la BDD d'origine avec un filtre avancé dessus.
la macro fonctionne bien seulement lorsque je change la BDD elle ne fonctionne plus et ce même si la BDD est plus petite. Excel se met à mouliner et il me dit que je n'ai pas assez de ressource.

en fait sur ma BDD de + de 3000 lignes il y en a 5 qui si je les supprime ou les efface font planter Excel...

Je ne peux pas vous mettre à dispo le fichier Excel car les données sont confidentielles.

Avez vous déjà eu ce genre de cas?

Voici le code de la macro :

Sub interco2()

Application.ScreenUpdating = False
Application.Calculation = xlManual

'suppression feuille

Dim Compteur As Integer, Nom As String
Application.DisplayAlerts = False
For Compteur = Worksheets.Count To 1 Step -1
Nom = Sheets(Compteur).Name
Select Case Nom
Case "Détail produits", "Taux de change", "Nouveaux", "To Do", "Flux", "ICP Total", "Format ICP"
Case Else
Sheets(Compteur).Delete
End Select
Next Compteur
Application.DisplayAlerts = True

'affichage de toutes les feuilles

Sheets("Conversion nouveaux produits").Visible = True
Sheets("Conversion nouveaux produits").Select
Sheets("Flux").Visible = True
Sheets("Conversion nouveaux produits").Select
Sheets("Taux de change").Visible = True
Sheets("Conversion nouveaux produits").Select
Sheets("Nomenclature produits Horizon").Visible = True
Sheets("Conversion nouveaux produits").Select
Sheets("Format ICP").Visible = True

Sheets("Conversion nouveaux produits").Select
ActiveWorkbook.RefreshAll


'Création feuille

Application.Calculation = xlManual

Sheets("Conversion nouveaux produits").Select

Dim c As Range
For Each c In Range("J4:J100")
Nom = c.Value
If Nom <> "" Then
Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Nom


' filtre avancé

Sheets("Détail produits").Select
Range("BW2").Select
ActiveCell.FormulaR1C1 = Nom
Range("B4:BI4").Select
Range("BI4").Activate
Application.CutCopyMode = False
Application.CutCopyMode = False
Dim myRange As Range
Set myRange = Range("B4:BI" & Range("B4").End(xlDown).Row)
myRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range("BL1:DS2"), CopyToRange:=Range("BL4:DS4"), Unique:=False

Range("BL5:DS5").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=3
Selection.Cut
Sheets(Nom).Select
Range("B5").Select
ActiveSheet.Paste

'Mise en page

Sheets("Détail produits").Select
Range("B2:BI4").Select
Selection.Copy
Sheets(Nom).Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Détail produits").Select
Columns("B:BI").Select
Range("BI1").Activate
Selection.Copy
Sheets(Nom).Select
Columns("B:BI").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Selection.ColumnWidth = 0.9
Rows("1:1").Select
Selection.RowHeight = 9#

Sheets("Format ICP").Select
Range("BJ2:BQ5").Select
Selection.Copy
Sheets(Nom).Select
Range("BJ2").Select
ActiveSheet.Paste
Range("BJ5:BQ5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("BJ5:BQ20000")
Range("BJ5:BQ20000").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("BJ5").Select

Range("B5:B20000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Columns("C:C").Select
Selection.EntireColumn.Hidden = True
Columns("G:I").Select
Selection.EntireColumn.Hidden = True
Columns("M:BI").Select
Selection.EntireColumn.Hidden = True

Range("BJ5").Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.FreezePanes = True

End If

Next c

' ICP Total

Sheets("ICP Total").Select

Cells.Select
Selection.Delete Shift:=xlUp

' filtre avancé

Sheets("Détail produits").Select
Range("BW2").Select
Selection.ClearContents
Range("B4:BI4").Select
Range("BI4").Activate
Application.CutCopyMode = False
Application.CutCopyMode = False
myRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range("BL1:DS2"), CopyToRange:=Range("BL4:DS4"), Unique:=False

Range("BL5:DS5").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=3
Selection.Cut
Sheets("ICP Total").Select
Range("B5").Select
ActiveSheet.Paste

'Mise en page

Sheets("Détail produits").Select
Range("B2:BI4").Select
Selection.Copy
Sheets("ICP Total").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Détail produits").Select
Columns("B:BI").Select
Range("BI1").Activate
Selection.Copy
Sheets("ICP Total").Select
Columns("B:BI").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Selection.ColumnWidth = 0.9
Rows("1:1").Select
Selection.RowHeight = 9#

Sheets("Format ICP").Select
Range("BJ2:BQ5").Select
Selection.Copy
Sheets("ICP Total").Select
Range("BJ2").Select
ActiveSheet.Paste
Range("BJ5:BQ5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("BJ5:BQ20000")
Range("BJ5:BQ20000").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("BJ5").Select

Range("B5:B20000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Columns("C:C").Select
Selection.EntireColumn.Hidden = True
Columns("G:I").Select
Selection.EntireColumn.Hidden = True
Columns("N:BI").Select
Selection.EntireColumn.Hidden = True

Columns("M:M").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight

Rows("4:4").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("ICP Total").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ICP Total").Sort.SortFields.Add Key:=Range( _
"D5:D1026"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ICP Total").Sort
.SetRange Range("B4:BT1026")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Columns("D:D").EntireColumn.AutoFit

Range("BJ5").Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.FreezePanes = True

'Cacher les feuilles

Sheets("Conversion nouveaux produits").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Flux").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Taux de change").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Nomenclature produits Horizon").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Format ICP").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("ICP Total").Select

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

Sheets("Détail produits").Select
Range("b2").Select

ICP.Hide

End Sub
 

Lone-wolf

XLDnaute Barbatruc
Bonsoir nomitse, le Forum

Je ne suis pas étonné que ça bloque avec tous ces select et doublons. Une fois que tu as complété la macro, il faut aussi penser à la nettoyer.

EDIT: For Each c In Range("J4:J100"). Tu veux faire un classeur avec 96 Onglets??? :eek:
Une fois que tu as mis en forme 1 onglet, supprime la macro de mise en forme.

Quelques exemples

VB:
Dim sh As Worksheet, f    'à mettre au début de la macro

Sheets("xxxxxxxx").Copy  Sheets("Détail produits") .Range("B1")
Sheets("Format ICP").Range("BJ2:BQ5").Copy

With Sheets("ICP Total")
         .Cells.Delete Shift:=xlUp
        .Range("BJ2").PasteSpecial  Paste:=xlPasteValues  'Si coller tout > xlPasteAll
         .Range("BJ5:BQ5").AutoFill Destination:=.Range("BJ5:BQ20000")
         .Range("d5:d6500").Sort .Range("e5"), xlAscending  'Colonne à adapter
         Applicaton.CutCopyMode = 0
        Application.GoTo .Range("a2")
End With

Sheets("Détail produits").Columns("B:BI").Copy

With Sheets("ICP Total")
         .Range("B1").PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        .Columns("A:A").ColumnWidth = 0.9
        .Rows("1:1").RowHeight = 9
End With

.Range("D:F").Columns.AutoFit  'nom de colonnes à modifier

.Range("C:C, G:I, N:BI").Columns.Hidden = True

'pour masquer les feuilles
f = Array("Conversion nouveaux produits", "Flux", "Taux de change", "Format ICP", "ICP Total")
    For Each sh In f
        Sheets(sh).Visible = False  'pour afficher - Sheets(sh).Visible = True
    Next sh
Application.Goto Sheets("Détail produits").Range("b2")
 
Dernière édition:

nomitse

XLDnaute Nouveau
Bonjour,

Merci du conseil, pour voir si c'est la macro qui est trop compliquée je l'ai réduite au minimum pour voir ce qui pouvait engendrer un problème.
Seulement elle plante toujours... alors que ça fonctionne avec la BDD originale. je ne comprends pas.

Merci d'avance
voici le code. :

Sub interco2()

Application.ScreenUpdating = False
Application.Calculation = xlManual

'suppression feuille

Dim Compteur As Integer, Nom As String
Application.DisplayAlerts = False
For Compteur = Worksheets.Count To 1 Step -1
Nom = Sheets(Compteur).Name
Select Case Nom
Case "Conversion nouveaux produits", "Détail produits", "Taux de change", "Nouveaux", "To Do", "Flux", "ICP Total", "Format ICP"
Case Else
Sheets(Compteur).Delete
End Select
Next Compteur
Application.DisplayAlerts = True


Sheets("Conversion nouveaux produits").Select
ActiveWorkbook.RefreshAll


'Création feuille

Application.Calculation = xlManual

Sheets("Conversion nouveaux produits").Select

Dim c As Range
For Each c In Range("J4:J10")
Nom = c.Value
If Nom <> "" Then
Sheets.Add Count:=1, after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Nom

' filtre avancé

Sheets("Détail produits").Select
Range("BW2").Select
ActiveCell.FormulaR1C1 = Nom
Range("B4:BI4").Select
Range("BI4").Activate
Application.CutCopyMode = False
Application.CutCopyMode = False
Dim myRange As Range
Set myRange = Range("B4:BI" & Range("B65536").End(xlUp).Row)
myRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range("BL1:DS2"), CopyToRange:=Range("BL4:DS4"), Unique:=False

Range("BL5:DS5").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=3
Selection.Cut
Sheets(Nom).Select
Range("B5").Select
ActiveSheet.Paste

End If

Next c

End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re

Il faut regarder les exemples que je t'ai donné. Enlève-moi ces Select.

Ici Set myRange = Range("B4:BI" & Range("B65536").End(xlUp).Row) à modifier par

Range("B4:BI" & Range("B" & Rows.Count).End(xlUp).Row)
Tu n'as pas le 65000 cellules remplies.

Sheets("Détail produits").Select - Range("BW2").Select - ActiveCell.FormulaR1C1 = Nom, à modifier par

With Sheets("Détail produits")
.Range("BW2") = Nom
.Range("BL5:S5").Cut
End with
Sheets(Nom).Range("B5").PasteSpecial Paste:=xlPasteAll
 

nomitse

XLDnaute Nouveau
Ok merci,

J'ai modifié selon tes conseils, ca bugé toujours, ca venait de
Range("BL5:DS5").Select
Range(Selection, Selection.End(xlDown)).Select

Je ne sais pas pourquoi mais je pense qu'il copiait toutes les lignes même les vide... je l'ai modifié et ca fonctionne maintenant.

Merci pour tes conseils.

Simon
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG