Re : Repondre par defaut aux messages de excel
Voila le code, tu trouveras l'endroit de la plantée en commentaires avec debut et fin de souci avec des smileys
merci d'avance
Jean-Louis
Sub PREPA_PR()
'
' Macro enregistrée le 06.08.2006 par Jean-Louis DANCET
'
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fichier
Range("C94").Select
ActiveCell.FormulaR1C1 = "=LEN(R[5]C)-LEN(R[4]C)-1"
Range("C97").Select
ActiveCell.FormulaR1C1 = "=RIGHT(R[2]C,R[-3]C)"
Range("C97").Select
fichier = [C97]
'Windows("SYNCHRO_PR_OUTLOOK.xls").activate'
Sheets("SYNC_PR").Select
Columns("$A:$AJ").Select
Application.CutCopyMode = False
Selection.ClearContents
Sheets("MACRO").Select
Workbooks.Open Filename:=[c99]
Windows(fichier).Activate
Sheets("Suivi Projet PR").Select
Dim premlivide As Double
Rows("1:3").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A1").Select
premlivide = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Range("B2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],""DB"",""OK"")"
Range("B2").Select
Selection.Copy
Range("b2:b" & premlivide).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "DOUBLE"
For Each C In Range("a:a")
CC = CC + 1
cellule = "B" & CC
If CC >= premlivide Then GoTo fin1
couleur = C.Font.ColorIndex
If C.Font.ColorIndex = 7 Then
Range(cellule).Select
ActiveCell.Value = "KO"
End If
Next C
fin1:
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[2]=""pas de date"",""KO"",IF(RC[2]=""à fixer"",""KO"",RC[-1]))"
Range("C2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B1").Select
ActiveCell.FormulaR1C1 = "DOUBLES"
Range("B2").Select
Application.WindowState = xlMinimized
Columns("B:B").Select
'fin de traitement dossier original
Columns("$A:$AK").Select
Selection.Copy
Windows("SYNCHRO_PR_OUTLOOK.xls").Activate
Sheets("SYNC_PR").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(fichier).Activate
😡
'le souci est la au close de la fenetre
ActiveWindow.Close
'fin de souci
😕
Windows("SYNCHRO_PR_OUTLOOK.xls").Activate
Sheets("SYNC_PR").Select
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Range("E2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],30)"
Range("E2").Select
Selection.Copy
Range("E2:E" & premlivide).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollRow = 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call SYNCHRO_PR
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("MACRO").Select
Range("A1").Select
ActiveWorkbook.Save
MsgBox ("Synchronisation de outlook terminee")
End Sub