[XL-2007] Freeze lors de cette fonction

[0x44-0x43-0x53-0x43]

Bonjours ,
lorsque je lance cette fonction mon application freeze ( ne répond plus ) je suis obliger de fermer par la suite :/

Voici le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
 
Sub sauver_facture()
 
Dim Nom_save As String
'--Variables de recherche ------------------------------------------------------
Dim objRange As Range, PlageRed As Range, objCell As Range, PlageResult As Range
Dim RechVirtuel As Range
Dim nbFeuille As Integer
 
Nom_save = FormSave.NomFichier.Value
 
 
 
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
'réduction de la plage
 
For Each objRange In ActiveWorkbook.Worksheets(1).Columns
    If IsNull(objRange.Interior.ColorIndex) Then
        If PlageRed Is Nothing Then
            Set PlageRed = objRange
        Else
            Set PlageRed = Application.Union(objRange, PlageRed)
        End If
    End If
Next
 
'travail en ligne
For Each objRange In ActiveWorkbook.Worksheets(1).Rows
    If IsNull(objRange.Interior.ColorIndex) Then
        For Each objCell In objRange.Cells
            If objCell.Interior.ColorIndex = 15 Then
                '--Traitement a l'interieur de cette boucle-----------------------
                objCell.Value = ""
                With objCell.Interior
                    .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                objCell.Offset(0, 1).Value = ""
                '--Fin Traitement-------------------------------------------------
            End If
        Next
    End If
Next
 
MsgBox "Hey"
 
'travail en ligne
For Each objRange In ActiveWorkbook.Worksheets(1).Rows
    If IsNull(objRange.Interior.ColorIndex) Then
        For Each objCell In objRange.Cells
            If objCell.Interior.Color = RGB(255, 0, 0) Then
                '--Traitement a l'interieur de cette boucle-----------------------
                objCell.Value = ""
                With objCell.Interior
                    .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                objCell.Offset(0, 1).Value = ""
                '--Fin Traitement-------------------------------------------------
            End If
        Next
    End If
Next
 
ActiveWorkbook.SaveAs Filename:=Repertoire_save & "\" & Nom_save & ".xls", FileFormat _
        :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False
 
End Sub

Le but est de copier toute la feuille (ThisWordBook.WorkSheet(1)) vers un autre workbook ( pour supprimer la macro en gros ) et de traiter le nouveau fichier .
si je remplace ActiveWorkBook par ThisWordBook ( c'est a dire si je travaille la ou est la macro ) la sa fonctionne mais si je travail sur le nouveau classeur
sa freeze :s.

Merci,
( ActiveWorkBook )

[Ormonth]

Bonjour,

Ne serait-il pas plus simple et moins lourd d'exporter ta feuille ( ou de sauvegarder sous un nouveau nom en ayant effacé les non-voulues) et de détruire le code genre :

Sauvegarder le classeur contenant cette macro, puis supprimer la totalité des procédures.
La macro "SupprimeTout" est aussi détruite.

http://silkyroad.developpez.com/VBA/...cEditor/#LIV-D

codialement,

Didier

[0x44-0x43-0x53-0x43]

Merci de votre réponse mais le but est d'enlever la macro mais aussi et surtout de traiter le WorkBook génère et non pas toucher au ThisWorkBook
Comment corriger ce probleme de freeze ?

Merci encore