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 : Sélectionner tout - Visualiser dans une fenêtre à part
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 )