Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Identification des instructions ralentissant une macro

Identification des instructions ralentissant une macro

9 réponses
Avatar
Christophe
Bonjour:

J'ai une macro qui est en grande issue de macros enregistr=E9es avec
l'enregistreur de macro et qui par consequent est tr=E8s lente (5 ou 6
mn).

Comment puis-je identifier les instructions qui ralentissent la macro?

Merci.

Christophe
Signaler un problème avec ce contenu

9 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
DanielCo
Bonjour.
Les instructions "Select" ralentissent et sont souvent inutiles.
Dautres sont complétement inutiles. Par contre, il en manque qui
peuvent accélérer la macro. Le mieux serait de poster ton code.
Cordialement.
Daniel


Bonjour:

J'ai une macro qui est en grande issue de macros enregistrées avec
l'enregistreur de macro et qui par consequent est très lente (5 ou 6
mn).

Comment puis-je identifier les instructions qui ralentissent la macro?

Merci.

Christophe
Avatar
michdenis
Bonjour,

D'une manière générale, mais ce n'est pas nécessaire pour toutes les macros...

'En début de macro :
Dim ModCalcul As String
ModCalcul = Application.Calculation
'Désactive les procédures événementiellles
Application.EnableEvents = False
'Passe en mode de calcul manuel
Application.Calculation = xlCalculationManual
'Désactive le rafraîchissement de l'écran
Application.ScreenUpdating = False

'La macro

à la fin de la macro :
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True

Les autres actions font référence à la manière dont le code est écrit.

A ) Le choix de l'approche dans le déroulement de la macro
B ) Éviter les boucles lorsque des alternatives existent.
C ) Éviter de sélectionner les objets ou plages de cellules qui sont inutiles dans
99% des cas.
D ) Définir le type des variables utilisées en début de procédure
E ) .../etc...

Tout ceci s'apprend et se développe avec la pratique et un peu de connaissances !

--
MichD
--------------------------------------------


"Christophe" a écrit dans le message de groupe de discussion :

Bonjour:

J'ai une macro qui est en grande issue de macros enregistrées avec
l'enregistreur de macro et qui par consequent est très lente (5 ou 6
mn).

Comment puis-je identifier les instructions qui ralentissent la macro?

Merci.

Christophe
Avatar
Christophe
Je vous remercie de toutes vos réponses. Je me permettrai d'ici
demain de poster le code de ma macro mais ne voulant pas être
responsable ni d'une crise cardiaque ni d'une perte irreversible de la
vue pour quiconque, je vous préviens à l'avance que c'est un véritabl e
champs de ruines qui devrait choquer à jamais même les moins
sensibles.

Remerciements et sincères saluations.

Christophe

On 22 sep, 18:08, Christophe wrote:
Bonjour:

J'ai une macro qui est en grande issue de macros enregistrées avec
l'enregistreur de macro et qui par consequent est très lente (5 ou 6
mn).

Comment puis-je identifier les instructions qui ralentissent la macro?

Merci.

Christophe
Avatar
Christophe
Bonjour:

Ci-dessous l'une des 2 macro en question (je vous avais prévenu).
Miraculeusement, le temps de traitement est passé à 1mn environ au
lieu de 5 ou 6 mn précedement après avoir enlever une private sub ce
qui est acceptable mais si je peux réduire ce temps de moitié c'est
encore mieux.

J'ai compris que les instructions select ralentissaient le traitement
et qu'elles étaient souvent inutiles. J'en ai beaucoup. Par quoi les
remplacer?

Merci par avance pour vos conseils.


Christophe



Sub ShowtimeCompanyScheduler()
If MsgBox(Prompt:="Are you really sure to want to GENERATE the
COMPANY SCHEDULES of Appointments? If yes, it can take up to a few
minutes depending on the number of companies/countries.",
Buttons:=vbYesNo + vbQuestion, _
Title:="Generate Company Schedules") = vbNo Then
Exit Sub
End If
' Showtime Scheduler Macro
' Macro enregistrée le 29/04/2003 par Christophe
Application.ScreenUpdating = False
' Unprotect Worksheet
ActiveWorkbook.Unprotect Password:="*****"
Worksheets("Company Data").Select

' save last changes made at Worksheet "Country Appointments"
Worksheets("Country Appointments").Select
'ActiveSheet.Unprotect Password:="*****"
Cells.Select
'Cells.EntireColumn.AutoFit
ActiveWorkbook.Save
'TEST CreateBackup = True
'ActiveSheet.Protect Password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True

'Delete all Worksheets except 9 of them
ActiveWorkbook.Unprotect Password:="*****"
Application.DisplayAlerts = False
For Each S In ActiveWorkbook.Worksheets
If S.Name <> "What is the Scheduler" And S.Name <>
"Instructions" And S.Name <> "Country Data" And S.Name <> _
"Company Data" And S.Name <> "Country Appointments" And
S.Name <> "Fax Template" And S.Name <> "Statistics" And S.Name <>
"EmailAllCountrySchedules" And S.Name <> "EmailAllCompanySchedules"
And S.Name <> "Transitory4" And S.Name <> "Transitory6" Then S.Delete
Next S
Application.DisplayAlerts = False

'Create Copy content-value of "Country Appointments" moins colonne
A into "Transitory1" (no formulas).
Cells.Select
Selection.Copy
Sheets.Add.Name = "Transitory1"
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone,
SkipBlanks:úlse _
, Transpose:úlse
Selection.Columns.AutoFit


'Run macro "SwapTableShowtime" Range is automaticaly selected
'Then result is saved into "Company Appointments" worksheet and
cell A1 is filled with Date / Time label
ActiveSheet.Name = "Transitory1"
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Application.Run "ShowtimeSwapTable"
ActiveSheet.Name = "Company Appointments"
Range("A1").Select
Application.CutCopyMode = False
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "DATE & TIME"

' Replace "H#" by empty cell otherwise program stop as it cannot
find empty cells in some colums.
'It might be possible and better instead to use something like
"Application.DisplayAlerts = False"
Cells.Select
Selection.Replace What:="H#", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:úlse

'Copy and paste result into "Transitory2" worksheet
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Range("A1").Select
Sheets.Add.Name = "Transitory2"
ActiveSheet.Paste
Columns("A:A").Select
Selection.NumberFormat = "m/d/yy h:mm AM/PM"

'Loop 256 times (if number of companies participating in Showtime
exceed 100 please increase number in macro)
'to copy the first two columns of "Transitory2" worksheet and
paste it each time in a new sheet
'named by the company name in cell "B1" (note that a variable
Onglet was created)
'Remove the date and time for which the company does not have
meeting scheduled by deleting rows with empty cell (F5 Special Blank)
' Each loop Deletes in "Transitory2" the column of the company
processed


For I = 1 To 120
If Application.WorksheetFunction.CountA(Range("B2:B115")) = 0
Then
GoTo Suite1
End If


Dim Onglet As String


Columns("A:B").Select
Selection.Copy
Sheets.Add
Range("A1").Select
ActiveSheet.Paste
Onglet = ActiveSheet.Range("B1").Value

'si la chaîne "Onglet" est vide
If Onglet = "" Then
Onglet = "ZZZZZ"
GoTo Suite
End If
'si le nom comprend des caractères interdits -> tiret bas
For j = 1 To Len(Onglet)
Select Case Mid(Onglet, j, 1)
Case "&", ":", "/", "", "?", "*", "[", "]": Mid(Onglet,
j, 1) = "_"
End Select
Next
'si le nom est trop long -> tronqué à 31 caractères
If Len(Onglet) > 31 Then
Onglet = Left(Onglet, 31)
End If

ActiveSheet.Name = Onglet
'Selection.SpecialCells(xlCellTypeBlanks).Select
'Application.CutCopyMode = False
'Selection.EntireRow.Delete

Range("B2:B150").SpecialCells(xlCellTypeBlanks).EntireRow.Delete



'Add 14 lines to the top of each sheet. Move company name 2
cells above. Rename column to "Country" and add name to column "Trade
Specialist".
'Merge column first and lastname. Copy formulas to look for
corresponding firstname and lastname into sheet "CountryData".
Columns("A").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1").Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert

'ChDir "C:Program FilesShowtime Scheduler"
Range("A1").Select
Rows("1:1").RowHeight = 110
ActiveSheet.Pictures.Insert("C:Program FilesShowtime
Scheduleruscslogo2.jpg").Select
With Selection
.Top = Range("A1").Top
.Left = Range("A1").Left
.Width = Range("A1").Width
.Height = Range("A1").Height
End With


Range("B15").Select
Selection.Cut
Range("B13").Select
ActiveSheet.Paste
Range("B13").Select
Selection.Font.Bold = True
Range("B15").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "COUNTRY"
Range("C15").Select
ActiveCell.FormulaR1C1 = "CONTACT NAME"
Range("A13").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Schedule for: "

'TEST Range("C13").Select
'TEST ActiveCell.Formula = "¡3&"" ""&B13"
' TEST Range("C13").Select
' TEST Selection.Copy
' TEST Range("D13").Select
' TEST Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:úlse
' TEST Range("A13:C13").Select
' TEST Selection.Delete Shift:=xlToLeft
' TEST Selection.Font.Bold = True
' TEST Range("A13").Select

'underline (border) titles
Range("A15:C15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone


Range("C16").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-1],CountryData,2,FALSE)),"""",
(VLOOKUP(RC[-1],CountryData,2,FALSE)))"
Range("C16").Select
Selection.Copy
Range("C17:D47").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Range("D16").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-2],CountryData,3,FALSE)),"""",
(VLOOKUP(RC[-2],CountryData,3,FALSE)))"
Range("D16").Select
Selection.Copy
Range("D17:D47").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Range("E15").Select
ActiveCell.Formula = "Á5&"" ""&D15"
Range("E15").Select
Selection.Copy
Range("E16:E48").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Columns("E:E").Select
Selection.Copy
Columns("F:F").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:úlse
Columns("C:F").Select
Range("F13").Activate
Application.CutCopyMode = False
Columns("C:E").Select
Range("E13").Activate
Selection.Delete Shift:=xlToLeft
Range("C15").Select
Selection.Font.Bold = True
Range("A15:C15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone

Range("A3").Select
ActiveCell.Formula =
"=IF(ISERROR(VLOOKUP(B13,COMPANY2,14,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,14,FALSE)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,15,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,15,FALSE)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,16,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,16,FALSE)))"

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A3").Select
Selection.Font.Bold = True

Range("A4:B4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A5:B5").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A6:B6").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A7:B7").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A8:B8").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

Range("A4").Select
Selection.Formula =
"=IF(or(ISERROR(VLOOKUP(B13,COMPANY2,17,False)),VLOOKUP(B13,COMPANY2,17,F alse)=0),"""",
(VLOOKUP(B13,COMPANY2,17,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

Range("A5").Select
Selection.Formula =
"=IF(ISERROR(VLOOKUP(B13,COMPANY2,1,False)),"""",
(VLOOKUP(B13,COMPANY2,1,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

Range("A6").Select
Selection.Formula =
"=IF(or(ISERROR(VLOOKUP(B13,COMPANY2,4,False)),VLOOKUP(B13,COMPANY2,4,Fal se)=0),"""",
(VLOOKUP(B13,COMPANY2,4,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

Range("A7").Select
ActiveCell.Formula =
"=IF(ISERROR(VLOOKUP(B13,COMPANY2,5,False)),"""",
(VLOOKUP(B13,COMPANY2,5,False)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,6,False)),"""",
(VLOOKUP(B13,COMPANY2,6,False)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,7,False)),"""",
(VLOOKUP(B13,COMPANY2,7,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

Range("A8").Select
ActiveCell.Formula = "=CONCATENATE(VLOOKUP(B13,COMPANY2,21),""
or VIA FAX: "",VLOOKUP(B13,COMPANY2,20))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A8").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

Range("A10").Select
ActiveCell.Formula = "=CONCATENATE(""Dear
"",VLOOKUP(B13,COMPANY2,14),"" "",VLOOKUP(B13,COMPANY2,16),"":"")"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse


Range("A12:D12").Select

'Rows("12:12").RowHeight = 150
ActiveCell.Formula = "=CONCATENATE(Body,""
"",VLOOKUP(B13,COMPANY2,2),"""",VLOOKUP(B13,COMPANY2,3,FALSE))"

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With

Range("A12").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A12:C12").Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Rows("12:12").RowHeight = 100
'Application.Run "AutoFitMergedCellRowHeight"
Columns("B:C").Select
Columns("B:C").EntireColumn.AutoFit



Range("A8:B8").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
'Range("A10:E10").Select
'With Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
' End With
'Selection.Merge
' With Selection
' .HorizontalAlignment = xlLeft
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
'End With

Range("C13").Select
Selection.Font.Bold = True
ActiveCell.Formula = "=CONCATENATE(""Booth#:
"",VLOOKUP(B13,COMPANY2,22),"" Tel/Cell# at show:
"",VLOOKUP(B13,COMPANY2,19))"
'Range("A8").Select
'ActiveCell.Formula = "=CONCATENATE(""VIA
FAX:"",VLOOKUP(B13,COMPANY2,20),"" or E-mail:
"",VLOOKUP(B13,COMPANY2,21)"


ActiveSheet.UsedRange
Range("a" & Range("a65536").End(xlUp).Row + 3).Select
Range("A" & ActiveCell.Row & ":C" & ActiveCell.Row).Merge
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With


Range("A" & ActiveCell.Row & ":C" &
ActiveCell.Row).FormulaR1C1 = "=Signature"
ActiveCell.RowHeight = 300
Range("C2").Select
ActiveCell.FormulaR1C1 = "=NOW()"
Selection.NumberFormat = "m/d/yy h:mm AM/PM"
Range("C2").Select
Columns("C:C").EntireColumn.AutoFit


Range("A2").Select

Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Range("B13").Select
'ActiveSheet.Protect password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True

Columns("A:C").Select
Columns("A:C").EntireColumn.AutoFit
'Maximize the size of the schedules columns
Cells.Select
Cells.EntireColumn.AutoFit

''Concatenate cells A13, B13 and C13
'Range("C13").Select
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse

'Range("D13").Select
'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],"" -
"",RC[-1])"
'Range("D13").Select
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=F alse,
Transpose:úlse
'Range("A13:C13").Select
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlToLeft
'Range("A13").Select
'With Selection.Font
' .Name = "Arial"
' .FontStyle = "Bold"
' .Size = 11
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
' .TintAndShade = 0
' .ThemeFont = xlThemeFontNone


'End With
Columns("A:A").Select
Selection.ColumnWidth = 32

'Range("$A$1:$C$" & Range("A65536").End(xlUp).Row).Select




'Maximize the size of the schedules for column B
Columns("B:C").Select
Columns("B:C").EntireColumn.AutoFit
'Range("$A$1:$C$" & Range("A65536").End(xlUp).Row).Select


Dim ce As Range
derlg = Cells(Rows.Count, "A").End(3).Row
Range("a15:ce" & derlg).Interior.ColorIndex = xlNone
For Each ce In Range("a15:a" & derlg)
If Range("a" & ce.Row) & Range("a" & ce.Row + 1) = "" Then
Exit For
Range(Cells(ce.Row, 1), Cells(ce.Row,
3)).Interior.ColorIndex = 15 * (ce.Row Mod 2)
Next





ActiveWindow.DisplayZeros = False

ActiveSheet.PageSetup.PrintArea = ("$A$1:$C$" &
Range("A65536").End(xlUp).Row)
With ActiveSheet.PageSetup

.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
'.PrintQuality = 600
.Orientation = xlPortrait
'.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Suite1:
Worksheets("Transitory2").Select
Worksheets("Transitory2").Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Next I
Suite:

'Delete the unwanted sheets ("1" and "2" and "3" and "4" and "5"
and "6" (hall#)
'as well as 0pen and "Transitory1". Note that "Transitory2" is not
deleted
'as one wants to keep it to check that all companies were
processed (need to be empty)
'Note that On Error Resume Next allow to continue even a sheet
does not exist


'Dim c As Range
'For Each c In Sheets("Company Data").Range("B4:B500").Cells
'Select Case c
'Case "What is the Scheduler", "Instructions", "Fax Template",
"Country Data", "Company Data", "Country Appointments", "Company
Appointments", "Statistics", "EmailAllCountrySchedules",
"EmailAllCompanySchedules"
'on fait rien
'Case Else
'On Error Resume Next
'Application.DisplayAlerts = False
'ThisWorkbook.Sheets(c.Value).Delete
'Application.DisplayAlerts = True
'On Error GoTo 0
'End Select
'Next
'Delete the unwanted sheets 0pen, "Transitory2" and and
"Transitory3". Note that "Transitory2" is not deleted
'as one wants to keep it to check that all companies were
processed (need to be empty)
'Note that On Error Resume Next allow to continue even a sheet
does not exist


On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory3").Delete
On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory1").Delete

'Delete all sheets starting with "Sheet" and followed by something
e.g. "sheet1" "sheet 150" sheet"999" etc.
Application.DisplayAlerts = False
For Each S In Sheets
If S.Name Like "Sheet*" Then S.Delete
Next
Application.DisplayAlerts = True

'Move sheet "Country Appointments" and "Company Appointments"
Sheets("What is the Scheduler").Select
Sheets("What is the Scheduler").Move Before:=Sheets(1)
Sheets("Instructions").Select
Sheets("Instructions").Move Before:=Sheets(2)
Sheets("Fax Template").Select
Sheets("Fax Template").Move Before:=Sheets(3)
Sheets("Country Data").Select
Sheets("Country Data").Move Before:=Sheets(4)
Sheets("Company Data").Select
Sheets("Company Data").Move Before:=Sheets(5)
Sheets("Country Appointments").Select
Sheets("Country Appointments").Move Before:=Sheets(6)
Sheets("Company Appointments").Select
Sheets("Company Appointments").Move Before:=Sheets(7)
Sheets("Statistics").Select
Sheets("Statistics").Move Before:=Sheets(8)
Sheets("EmailAllCompanySchedules").Select
Sheets("EmailAllCompanySchedules").Move Before:=Sheets(9)
Sheets("EmailAllCountrySchedules").Select
Sheets("EmailAllCountrySchedules").Move Before:=Sheets(10)
Sheets("Transitory4").Select
Sheets("Transitory4").Move Before:=Sheets(11)
Sheets("Transitory6").Select
Sheets("Transitory6").Move Before:=Sheets(12)
Sheets("Transitory2").Select
Sheets("Transitory2").Move Before:=Sheets(13)

Sheets("Company Appointments").Select
ActiveWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
Range("B2").Select

'Sheets("Country Data").Select
'Sheets("Country Data").Move before:=Sheets(3)
'Sheets("Country Appointments").Select
'Sheets("Country Appointments").Move before:=Sheets(5)
'ActiveWindow.ScrollWorkbookTabs Position:=xlLast
'Sheets("Company Appointments").Select
'Sheets("Company Appointments").Move before:=Sheets(6)
'ActiveWindow.ScrollWorkbookTabs Sheets:=-1
'Sheets("Company Appointments").Select

'Freeze 1 column and 1 row of "company appointments".
'ActiveCell("C2") is supposed to display the top part of the sheet
but does not work (need to be fixed)
Range("B2").Select
ActiveWorkbook.Unprotect Password:="*****"
ActiveWindow.FreezePanes = True
'Range("C2").Activate
'Sheets("Country Appointments").Select


' This Macro below was added to create the Transitory6 sheet which
feed the EmailAllCompanySchedules template.

On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory5").Delete
Sheets.Add.Name = "Transitory5"
Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
'Application.CutCopyMode = False
Cells.Select
Selection.ClearContents
Sheets("Company Data").Select
Range("A4:AJ503").Select
Selection.Copy
Sheets("Transitory5").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse ,
Transpose:úlse
Cells.Select
Selection.Copy
Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse ,
Transpose:úlse



'Delete all sheets starting with "Sheet" and followed by something
e.g. "sheet1" "sheet 150" sheet"999" etc.
Application.DisplayAlerts = False
For Each S In Sheets
If S.Name Like "Sheet*" Then S.Delete
Next
For Each S In Sheets
If S.Name Like "Feuil*" Then S.Delete
Next
Application.DisplayAlerts = True




' This Macro below was added to feed the EmailAllCompanySchedules
with the sheet tab names.

Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Unprotect Password:="*****"
Dim Ws As Worksheet, wb As Workbook, R As Range, Ig As Integer
Set wb = ActiveWorkbook
Set R = ActiveSheet.Range("C7")
Ig = 1
For Each Ws In wb.Worksheets
R.Cells(Ig, 1) = Ws.Name
Ig = Ig + 1
Next Ws


'Range("C21:C140").Select
'Selection.Copy
'Range("C7").Select
'ActiveSheet.Paste
'Range("C126:C141").Select
'Selection.Delete Shift:=xlUp


Range("C7:C21").Select
Selection.ClearContents
Range("C22:C139").Select
Selection.Copy
Range("C7").Select
ActiveSheet.Paste
Range("C127:C139").Select
Selection.ClearContents


Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
Dim Wst As Worksheet
Dim mystr As String, cr As Range, It As Integer
For Each cr In [C4:C503]
mystr = ""
For It = 1 To Len(cr)
x = Mid(cr, It, 1)
If InStr("/?;*&:[]", x) > 0 Then
mystr = mystr & "_"
Else
mystr = mystr & x
End If
Next It
cr.Offset(, -1) = mystr
Next cr
Range("A4").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],31)"
Range("A4").Select
Selection.AutoFill Destination:=Range("A4:A503"),
Type:=xlFillDefault

Cells.Select
Cells.EntireColumn.AutoFit
Selection.RowHeight = 15




Sheets("Transitory5").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Company Data").Select
Range("1:1,2:2,3:3,AJ:AJ").Select
Selection.Locked = True
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True
Sheets("Company Appointments").Select
ActiveWorkbook.Save
ActiveWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
Range("B2").Select
Sheets("Company Appointments").Protect Password:="*****",
DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True

Sheets("Country Appointments").Protect Password:="*****",
DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True

Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Protect Password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True
Worksheets("EmailAllCompanySchedules").Select
Range("A8").Select
End Sub














> Bonjour:

> J'ai une macro qui est en grande issue de macros enregistrées avec
> l'enregistreur de macro et qui par consequent est très lente (5 ou 6
> mn).

> Comment puis-je identifier les instructions qui ralentissent la macro?

> Merci.

> Christophe- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -
Avatar
Jacquouille
Bonjour Christophe
Dans ta question, tu dis avoir employé l'enregistreur.
C'est une bête fantastique, mais qui bouffe beaucoup.
J'ai remarqué, dnas la deuxième moitié de ta macro, que tu sélectionnais
beaucoup de choses.
Si je puis me permettre, et sans vouloir me substituer à mes copains
répondeurs...
Ouvre une feuille blanche, puis l'enregistreur. Sélectionne B2, colorie en
vert, puis tu stoppes la macro. Tu verras ..
Dans ta macro, essaie de trouver exactement l'action voulue et supprime les
autres données telles que couleur du texte, caractère gras ou épaisseur de
bordure ....
Ensuite, tu corrigeras ta macro initiale et tu gagneras au moins 50 lignes.
Bonne chance

--
Bien amicalmement,
"Le vin est au repas ce que le parfum est à la femme."

Jacquouille (MPFE).

"Christophe" a écrit dans le message de news:

Bonjour:

Ci-dessous l'une des 2 macro en question (je vous avais prévenu).
Miraculeusement, le temps de traitement est passé à 1mn environ au
lieu de 5 ou 6 mn précedement après avoir enlever une private sub ce
qui est acceptable mais si je peux réduire ce temps de moitié c'est
encore mieux.

J'ai compris que les instructions select ralentissaient le traitement
et qu'elles étaient souvent inutiles. J'en ai beaucoup. Par quoi les
remplacer?

Merci par avance pour vos conseils.


Christophe



Sub ShowtimeCompanyScheduler()
If MsgBox(Prompt:="Are you really sure to want to GENERATE the
COMPANY SCHEDULES of Appointments? If yes, it can take up to a few
minutes depending on the number of companies/countries.",
Buttons:=vbYesNo + vbQuestion, _
Title:="Generate Company Schedules") = vbNo Then
Exit Sub
End If
' Showtime Scheduler Macro
' Macro enregistrée le 29/04/2003 par Christophe
Application.ScreenUpdating = False
' Unprotect Worksheet
ActiveWorkbook.Unprotect Password:="*****"
Worksheets("Company Data").Select

' save last changes made at Worksheet "Country Appointments"
Worksheets("Country Appointments").Select
'ActiveSheet.Unprotect Password:="*****"
Cells.Select
'Cells.EntireColumn.AutoFit
ActiveWorkbook.Save
'TEST CreateBackup = True
'ActiveSheet.Protect Password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True

'Delete all Worksheets except 9 of them
ActiveWorkbook.Unprotect Password:="*****"
Application.DisplayAlerts = False
For Each S In ActiveWorkbook.Worksheets
If S.Name <> "What is the Scheduler" And S.Name <>
"Instructions" And S.Name <> "Country Data" And S.Name <> _
"Company Data" And S.Name <> "Country Appointments" And
S.Name <> "Fax Template" And S.Name <> "Statistics" And S.Name <>
"EmailAllCountrySchedules" And S.Name <> "EmailAllCompanySchedules"
And S.Name <> "Transitory4" And S.Name <> "Transitory6" Then S.Delete
Next S
Application.DisplayAlerts = False

'Create Copy content-value of "Country Appointments" moins colonne
A into "Transitory1" (no formulas).
Cells.Select
Selection.Copy
Sheets.Add.Name = "Transitory1"
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone,
SkipBlanks:úlse _
, Transpose:úlse
Selection.Columns.AutoFit


'Run macro "SwapTableShowtime" Range is automaticaly selected
'Then result is saved into "Company Appointments" worksheet and
cell A1 is filled with Date / Time label
ActiveSheet.Name = "Transitory1"
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Application.Run "ShowtimeSwapTable"
ActiveSheet.Name = "Company Appointments"
Range("A1").Select
Application.CutCopyMode = False
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "DATE & TIME"

' Replace "H#" by empty cell otherwise program stop as it cannot
find empty cells in some colums.
'It might be possible and better instead to use something like
"Application.DisplayAlerts = False"
Cells.Select
Selection.Replace What:="H#", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:úlse

'Copy and paste result into "Transitory2" worksheet
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Range("A1").Select
Sheets.Add.Name = "Transitory2"
ActiveSheet.Paste
Columns("A:A").Select
Selection.NumberFormat = "m/d/yy h:mm AM/PM"

'Loop 256 times (if number of companies participating in Showtime
exceed 100 please increase number in macro)
'to copy the first two columns of "Transitory2" worksheet and
paste it each time in a new sheet
'named by the company name in cell "B1" (note that a variable
Onglet was created)
'Remove the date and time for which the company does not have
meeting scheduled by deleting rows with empty cell (F5 Special Blank)
' Each loop Deletes in "Transitory2" the column of the company
processed


For I = 1 To 120
If Application.WorksheetFunction.CountA(Range("B2:B115")) = 0
Then
GoTo Suite1
End If


Dim Onglet As String


Columns("A:B").Select
Selection.Copy
Sheets.Add
Range("A1").Select
ActiveSheet.Paste
Onglet = ActiveSheet.Range("B1").Value

'si la chaîne "Onglet" est vide
If Onglet = "" Then
Onglet = "ZZZZZ"
GoTo Suite
End If
'si le nom comprend des caractères interdits -> tiret bas
For j = 1 To Len(Onglet)
Select Case Mid(Onglet, j, 1)
Case "&", ":", "/", "", "?", "*", "[", "]": Mid(Onglet,
j, 1) = "_"
End Select
Next
'si le nom est trop long -> tronqué à 31 caractères
If Len(Onglet) > 31 Then
Onglet = Left(Onglet, 31)
End If

ActiveSheet.Name = Onglet
'Selection.SpecialCells(xlCellTypeBlanks).Select
'Application.CutCopyMode = False
'Selection.EntireRow.Delete

Range("B2:B150").SpecialCells(xlCellTypeBlanks).EntireRow.Delete



'Add 14 lines to the top of each sheet. Move company name 2
cells above. Rename column to "Country" and add name to column "Trade
Specialist".
'Merge column first and lastname. Copy formulas to look for
corresponding firstname and lastname into sheet "CountryData".
Columns("A").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1").Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert

'ChDir "C:Program FilesShowtime Scheduler"
Range("A1").Select
Rows("1:1").RowHeight = 110
ActiveSheet.Pictures.Insert("C:Program FilesShowtime
Scheduleruscslogo2.jpg").Select
With Selection
.Top = Range("A1").Top
.Left = Range("A1").Left
.Width = Range("A1").Width
.Height = Range("A1").Height
End With


Range("B15").Select
Selection.Cut
Range("B13").Select
ActiveSheet.Paste
Range("B13").Select
Selection.Font.Bold = True
Range("B15").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "COUNTRY"
Range("C15").Select
ActiveCell.FormulaR1C1 = "CONTACT NAME"
Range("A13").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Schedule for: "

'TEST Range("C13").Select
'TEST ActiveCell.Formula = "¡3&"" ""&B13"
' TEST Range("C13").Select
' TEST Selection.Copy
' TEST Range("D13").Select
' TEST Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:úlse
' TEST Range("A13:C13").Select
' TEST Selection.Delete Shift:=xlToLeft
' TEST Selection.Font.Bold = True
' TEST Range("A13").Select

'underline (border) titles
Range("A15:C15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone


Range("C16").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-1],CountryData,2,FALSE)),"""",
(VLOOKUP(RC[-1],CountryData,2,FALSE)))"
Range("C16").Select
Selection.Copy
Range("C17:D47").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Range("D16").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-2],CountryData,3,FALSE)),"""",
(VLOOKUP(RC[-2],CountryData,3,FALSE)))"
Range("D16").Select
Selection.Copy
Range("D17:D47").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Range("E15").Select
ActiveCell.Formula = "Á5&"" ""&D15"
Range("E15").Select
Selection.Copy
Range("E16:E48").Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Application.CutCopyMode = False

Columns("E:E").Select
Selection.Copy
Columns("F:F").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:úlse
Columns("C:F").Select
Range("F13").Activate
Application.CutCopyMode = False
Columns("C:E").Select
Range("E13").Activate
Selection.Delete Shift:=xlToLeft
Range("C15").Select
Selection.Font.Bold = True
Range("A15:C15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone

Range("A3").Select
ActiveCell.Formula "=IF(ISERROR(VLOOKUP(B13,COMPANY2,14,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,14,FALSE)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,15,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,15,FALSE)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,16,FALSE)),"""",
(VLOOKUP(B13,COMPANY2,16,FALSE)))"

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A3").Select
Selection.Font.Bold = True

Range("A4:B4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A5:B5").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A6:B6").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A7:B7").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A8:B8").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

Range("A4").Select
Selection.Formula "=IF(or(ISERROR(VLOOKUP(B13,COMPANY2,17,False)),VLOOKUP(B13,COMPANY2,17,False)=0),"""",
(VLOOKUP(B13,COMPANY2,17,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

Range("A5").Select
Selection.Formula "=IF(ISERROR(VLOOKUP(B13,COMPANY2,1,False)),"""",
(VLOOKUP(B13,COMPANY2,1,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

Range("A6").Select
Selection.Formula "=IF(or(ISERROR(VLOOKUP(B13,COMPANY2,4,False)),VLOOKUP(B13,COMPANY2,4,False)=0),"""",
(VLOOKUP(B13,COMPANY2,4,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

Range("A7").Select
ActiveCell.Formula "=IF(ISERROR(VLOOKUP(B13,COMPANY2,5,False)),"""",
(VLOOKUP(B13,COMPANY2,5,False)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,6,False)),"""",
(VLOOKUP(B13,COMPANY2,6,False)))&""
""&IF(ISERROR(VLOOKUP(B13,COMPANY2,7,False)),"""",
(VLOOKUP(B13,COMPANY2,7,False)))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

Range("A8").Select
ActiveCell.Formula = "=CONCATENATE(VLOOKUP(B13,COMPANY2,21),""
or VIA FAX: "",VLOOKUP(B13,COMPANY2,20))"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A8").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

Range("A10").Select
ActiveCell.Formula = "=CONCATENATE(""Dear
"",VLOOKUP(B13,COMPANY2,14),"" "",VLOOKUP(B13,COMPANY2,16),"":"")"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse


Range("A12:D12").Select

'Rows("12:12").RowHeight = 150
ActiveCell.Formula = "=CONCATENATE(Body,""
"",VLOOKUP(B13,COMPANY2,2),"""",VLOOKUP(B13,COMPANY2,3,FALSE))"

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With

Range("A12").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A12:C12").Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Rows("12:12").RowHeight = 100
'Application.Run "AutoFitMergedCellRowHeight"
Columns("B:C").Select
Columns("B:C").EntireColumn.AutoFit



Range("A8:B8").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
'Range("A10:E10").Select
'With Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
' End With
'Selection.Merge
' With Selection
' .HorizontalAlignment = xlLeft
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
'End With

Range("C13").Select
Selection.Font.Bold = True
ActiveCell.Formula = "=CONCATENATE(""Booth#:
"",VLOOKUP(B13,COMPANY2,22),"" Tel/Cell# at show:
"",VLOOKUP(B13,COMPANY2,19))"
'Range("A8").Select
'ActiveCell.Formula = "=CONCATENATE(""VIA
FAX:"",VLOOKUP(B13,COMPANY2,20),"" or E-mail:
"",VLOOKUP(B13,COMPANY2,21)"


ActiveSheet.UsedRange
Range("a" & Range("a65536").End(xlUp).Row + 3).Select
Range("A" & ActiveCell.Row & ":C" & ActiveCell.Row).Merge
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With


Range("A" & ActiveCell.Row & ":C" &
ActiveCell.Row).FormulaR1C1 = "=Signature"
ActiveCell.RowHeight = 300
Range("C2").Select
ActiveCell.FormulaR1C1 = "=NOW()"
Selection.NumberFormat = "m/d/yy h:mm AM/PM"
Range("C2").Select
Columns("C:C").EntireColumn.AutoFit


Range("A2").Select

Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Range("B13").Select
'ActiveSheet.Protect password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True

Columns("A:C").Select
Columns("A:C").EntireColumn.AutoFit
'Maximize the size of the schedules columns
Cells.Select
Cells.EntireColumn.AutoFit

''Concatenate cells A13, B13 and C13
'Range("C13").Select
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse

'Range("D13").Select
'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],"" -
"",RC[-1])"
'Range("D13").Select
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:úlse,
Transpose:úlse
'Range("A13:C13").Select
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlToLeft
'Range("A13").Select
'With Selection.Font
' .Name = "Arial"
' .FontStyle = "Bold"
' .Size = 11
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
' .TintAndShade = 0
' .ThemeFont = xlThemeFontNone


'End With
Columns("A:A").Select
Selection.ColumnWidth = 32

'Range("$A$1:$C$" & Range("A65536").End(xlUp).Row).Select




'Maximize the size of the schedules for column B
Columns("B:C").Select
Columns("B:C").EntireColumn.AutoFit
'Range("$A$1:$C$" & Range("A65536").End(xlUp).Row).Select


Dim ce As Range
derlg = Cells(Rows.Count, "A").End(3).Row
Range("a15:ce" & derlg).Interior.ColorIndex = xlNone
For Each ce In Range("a15:a" & derlg)
If Range("a" & ce.Row) & Range("a" & ce.Row + 1) = "" Then
Exit For
Range(Cells(ce.Row, 1), Cells(ce.Row,
3)).Interior.ColorIndex = 15 * (ce.Row Mod 2)
Next





ActiveWindow.DisplayZeros = False

ActiveSheet.PageSetup.PrintArea = ("$A$1:$C$" &
Range("A65536").End(xlUp).Row)
With ActiveSheet.PageSetup

.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
'.PrintQuality = 600
.Orientation = xlPortrait
'.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Suite1:
Worksheets("Transitory2").Select
Worksheets("Transitory2").Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Next I
Suite:

'Delete the unwanted sheets ("1" and "2" and "3" and "4" and "5"
and "6" (hall#)
'as well as 0pen and "Transitory1". Note that "Transitory2" is not
deleted
'as one wants to keep it to check that all companies were
processed (need to be empty)
'Note that On Error Resume Next allow to continue even a sheet
does not exist


'Dim c As Range
'For Each c In Sheets("Company Data").Range("B4:B500").Cells
'Select Case c
'Case "What is the Scheduler", "Instructions", "Fax Template",
"Country Data", "Company Data", "Country Appointments", "Company
Appointments", "Statistics", "EmailAllCountrySchedules",
"EmailAllCompanySchedules"
'on fait rien
'Case Else
'On Error Resume Next
'Application.DisplayAlerts = False
'ThisWorkbook.Sheets(c.Value).Delete
'Application.DisplayAlerts = True
'On Error GoTo 0
'End Select
'Next
'Delete the unwanted sheets 0pen, "Transitory2" and and
"Transitory3". Note that "Transitory2" is not deleted
'as one wants to keep it to check that all companies were
processed (need to be empty)
'Note that On Error Resume Next allow to continue even a sheet
does not exist


On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory3").Delete
On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory1").Delete

'Delete all sheets starting with "Sheet" and followed by something
e.g. "sheet1" "sheet 150" sheet"999" etc.
Application.DisplayAlerts = False
For Each S In Sheets
If S.Name Like "Sheet*" Then S.Delete
Next
Application.DisplayAlerts = True

'Move sheet "Country Appointments" and "Company Appointments"
Sheets("What is the Scheduler").Select
Sheets("What is the Scheduler").Move Before:=Sheets(1)
Sheets("Instructions").Select
Sheets("Instructions").Move Before:=Sheets(2)
Sheets("Fax Template").Select
Sheets("Fax Template").Move Before:=Sheets(3)
Sheets("Country Data").Select
Sheets("Country Data").Move Before:=Sheets(4)
Sheets("Company Data").Select
Sheets("Company Data").Move Before:=Sheets(5)
Sheets("Country Appointments").Select
Sheets("Country Appointments").Move Before:=Sheets(6)
Sheets("Company Appointments").Select
Sheets("Company Appointments").Move Before:=Sheets(7)
Sheets("Statistics").Select
Sheets("Statistics").Move Before:=Sheets(8)
Sheets("EmailAllCompanySchedules").Select
Sheets("EmailAllCompanySchedules").Move Before:=Sheets(9)
Sheets("EmailAllCountrySchedules").Select
Sheets("EmailAllCountrySchedules").Move Before:=Sheets(10)
Sheets("Transitory4").Select
Sheets("Transitory4").Move Before:=Sheets(11)
Sheets("Transitory6").Select
Sheets("Transitory6").Move Before:=Sheets(12)
Sheets("Transitory2").Select
Sheets("Transitory2").Move Before:=Sheets(13)

Sheets("Company Appointments").Select
ActiveWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
Range("B2").Select

'Sheets("Country Data").Select
'Sheets("Country Data").Move before:=Sheets(3)
'Sheets("Country Appointments").Select
'Sheets("Country Appointments").Move before:=Sheets(5)
'ActiveWindow.ScrollWorkbookTabs Position:=xlLast
'Sheets("Company Appointments").Select
'Sheets("Company Appointments").Move before:=Sheets(6)
'ActiveWindow.ScrollWorkbookTabs Sheets:=-1
'Sheets("Company Appointments").Select

'Freeze 1 column and 1 row of "company appointments".
'ActiveCell("C2") is supposed to display the top part of the sheet
but does not work (need to be fixed)
Range("B2").Select
ActiveWorkbook.Unprotect Password:="*****"
ActiveWindow.FreezePanes = True
'Range("C2").Activate
'Sheets("Country Appointments").Select


' This Macro below was added to create the Transitory6 sheet which
feed the EmailAllCompanySchedules template.

On Error Resume Next
SendKeys ("{ENTER}")
Sheets("Transitory5").Delete
Sheets.Add.Name = "Transitory5"
Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
'Application.CutCopyMode = False
Cells.Select
Selection.ClearContents
Sheets("Company Data").Select
Range("A4:AJ503").Select
Selection.Copy
Sheets("Transitory5").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse,
Transpose:úlse
Cells.Select
Selection.Copy
Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse,
Transpose:úlse



'Delete all sheets starting with "Sheet" and followed by something
e.g. "sheet1" "sheet 150" sheet"999" etc.
Application.DisplayAlerts = False
For Each S In Sheets
If S.Name Like "Sheet*" Then S.Delete
Next
For Each S In Sheets
If S.Name Like "Feuil*" Then S.Delete
Next
Application.DisplayAlerts = True




' This Macro below was added to feed the EmailAllCompanySchedules
with the sheet tab names.

Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Unprotect Password:="*****"
Dim Ws As Worksheet, wb As Workbook, R As Range, Ig As Integer
Set wb = ActiveWorkbook
Set R = ActiveSheet.Range("C7")
Ig = 1
For Each Ws In wb.Worksheets
R.Cells(Ig, 1) = Ws.Name
Ig = Ig + 1
Next Ws


'Range("C21:C140").Select
'Selection.Copy
'Range("C7").Select
'ActiveSheet.Paste
'Range("C126:C141").Select
'Selection.Delete Shift:=xlUp


Range("C7:C21").Select
Selection.ClearContents
Range("C22:C139").Select
Selection.Copy
Range("C7").Select
ActiveSheet.Paste
Range("C127:C139").Select
Selection.ClearContents


Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:="*****"
Dim Wst As Worksheet
Dim mystr As String, cr As Range, It As Integer
For Each cr In [C4:C503]
mystr = ""
For It = 1 To Len(cr)
x = Mid(cr, It, 1)
If InStr("/?;*&:[]", x) > 0 Then
mystr = mystr & "_"
Else
mystr = mystr & x
End If
Next It
cr.Offset(, -1) = mystr
Next cr
Range("A4").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],31)"
Range("A4").Select
Selection.AutoFill Destination:=Range("A4:A503"),
Type:=xlFillDefault

Cells.Select
Cells.EntireColumn.AutoFit
Selection.RowHeight = 15




Sheets("Transitory5").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Company Data").Select
Range("1:1,2:2,3:3,AJ:AJ").Select
Selection.Locked = True
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True
Sheets("Company Appointments").Select
ActiveWorkbook.Save
ActiveWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
Range("B2").Select
Sheets("Company Appointments").Protect Password:="*****",
DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True

Sheets("Country Appointments").Protect Password:="*****",
DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowInsertingHyperlinks:=True

Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Protect Password:="*****", DrawingObjects:=True,
Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True,
AllowFormattingColumns:=True, _
AllowFormattingRows:=True
Worksheets("EmailAllCompanySchedules").Select
Range("A8").Select
End Sub














> Bonjour:

> J'ai une macro qui est en grande issue de macros enregistrées avec
> l'enregistreur de macro et qui par consequent est très lente (5 ou 6
> mn).

> Comment puis-je identifier les instructions qui ralentissent la macro?

> Merci.

> Christophe- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -
Avatar
Christophe
Bonjour:

J'ai essayé de poster plusieurs fois mon code vba mais il n'apparaît
pas.

Merci.

Christophe

On 22 sep, 18:45, DanielCo wrote:
Bonjour.
Les instructions "Select" ralentissent et sont souvent inutiles.
Dautres sont complétement inutiles. Par contre, il en manque qui
peuvent accélérer la macro. Le mieux serait de poster ton code.
Cordialement.
Daniel
Avatar
DanielCo
Bonjour.
Tu fais un copier du code et un coller dans le message.
Daniel


Bonjour:

J'ai essayé de poster plusieurs fois mon code vba mais il n'apparaît
pas.

Merci.

Christophe

On 22 sep, 18:45, DanielCo wrote:
Bonjour.
Les instructions "Select" ralentissent et sont souvent inutiles.
Dautres sont complétement inutiles. Par contre, il en manque qui
peuvent accélérer la macro. Le mieux serait de poster ton code.
Cordialement.
Daniel
Avatar
LSteph
Bonjour,

Essaye plutôt de voir d'abord ce que tu arrive à alleger par toi même .
Puisque c'est du code généré par enregistrement il est certain que tu
peux mettre déjà en application les conseils donnés par Daniel et MD

Notament Déclaration de variable , optimiser le type au plus léger
mais qui couvre l'ensemble des cas
éviter les objets quand ce n'est pas nécessaire.
Il y a sûrement des select, ils sont généralement inutiles
Exemple:

Range("A1").select
selection.copy
'à remplacer par
[A1].copy

outre la performance on peut aussi alleger la lisibilité, cas
classique Mise en page
quadrillage..etc.. qui produisent énormément de lignes pour parfois
changer seulement
peu de choses.

Exemple, avec tout ceci ....:
Range("B2:E11").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

..alors que ceci fait pareil:

With [B2:E11].Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
.Item(xlDiagonalDown).LineStyle = xlNone 'facultatif
.Item(xlDiagonalUp).LineStyle = xlNone 'facultatif
End With


'LSteph

On 23 sep, 10:51, Christophe wrote:
Bonjour:

J'ai essayé de poster plusieurs fois mon code vba mais il n'apparaît
pas.

Merci.

Christophe

On 22 sep, 18:45, DanielCo wrote:



> Bonjour.
> Les instructions "Select" ralentissent et sont souvent inutiles.
> Dautres sont complétement inutiles. Par contre, il en manque qui
> peuvent accélérer la macro. Le mieux serait de poster ton code.
> Cordialement.
> Daniel- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -
Avatar
Christophe
Bonjour:

Merci des conseils. Je vais essayer de mettre en application.

Sincères salutations.

Christophe

On 23 sep, 11:42, LSteph wrote:
Bonjour,

Essaye plutôt de voir d'abord ce que tu arrive à alleger par toi mê me.
Puisque c'est du code généré par enregistrement il est certain que tu
peux mettre déjà en application les conseils donnés par Daniel et M D

Notament Déclaration de variable , optimiser le type au plus léger
mais qui couvre l'ensemble des cas
éviter les objets quand ce n'est pas nécessaire.
Il y a sûrement des select, ils sont généralement inutiles
Exemple:

Range("A1").select
selection.copy
 'à remplacer par
[A1].copy

outre la performance on peut aussi alleger la lisibilité, cas
classique Mise en page
quadrillage..etc.. qui produisent énormément de lignes pour parfois
changer seulement
peu de choses.

Exemple, avec tout ceci ....:
Range("B2:E11").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

..alors que ceci fait pareil:

With [B2:E11].Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
        .Item(xlDiagonalDown).LineStyle = xlNone 'facultatif
         .Item(xlDiagonalUp).LineStyle = xlNone 'facultatif
    End With

'LSteph

On 23 sep, 10:51, Christophe wrote:



> Bonjour:

> J'ai essayé de poster plusieurs fois mon code vba mais il n'apparaî t
> pas.

> Merci.

> Christophe

> On 22 sep, 18:45, DanielCo wrote:

> > Bonjour.
> > Les instructions "Select" ralentissent et sont souvent inutiles.
> > Dautres sont complétement inutiles. Par contre, il en manque qui
> > peuvent accélérer la macro. Le mieux serait de poster ton code.
> > Cordialement.
> > Daniel- Masquer le texte des messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -