Bug données Macro

N

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
 
Trier par date Trier par votes
Lone-wolf

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:
Vote positif 0 Vote négatif
N

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
 
Vote positif 0 Vote négatif
Lone-wolf

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
 
Vote positif 0 Vote négatif
N

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
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 deux macros succesives et un bouton
2
Réponses
16
Affichages
656
Phil69970
Phil69970
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
505
robpellan52
R
F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
3 K
fanou06
F
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
326
marie3107
M
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
930
Nicolas JACQUIN
Nicolas JACQUIN
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
769
Kevin38
K
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
483
marie3107
M
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
444
job75
job75
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
829
mouchtre
mouchtre

Membres actuellement en ligne

18 membres et 165 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 716
Messages
2 112 159
Membres
111 447
dernier inscrit
jasontantane