Outils pour optimiser macro?

Le
Christophe
Bonjour:

Je souhaiterais savoir s'il existe des outils et ou techniques pour
diagnostiquer et/ou optimiser et/ou nettoyer le code d'une macro afin
d'augmenter la rapidité de traitement ou les points de ralentissement.

Remerciements et sincères.

Christophe
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Maude Este
Le #22571851
Bonsour®

"Christophe" a écrit
Je souhaiterais savoir s'il existe des outils et ou techniques pour
diagnostiquer et/ou optimiser et/ou nettoyer le code d'une macro afin
d'augmenter la rapidité de traitement ou les points de ralentissement.



http://xcell05.free.fr/pages/prog/accvba.htm
Christophe
Le #22575111
Bonjour Maud et merci.

Est-ce que tu peux m'aider à identifier les elements de la macro ci-
dessous à modifier pour accélérer la vitesse de traitement? Beaucoup
de ces lignes ont été réalisées avec l'enregistreur de Macro ce qui ne
doit pas participer à la fluidité de la macro.

Remerciements et sincères salutations,

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 "Instructions" And S.Name "Company Data" And S.Name <> "Country Appointments" And
S.Name "EmailAllCountrySchedules" And S.Name <> "EmailAllCompanySchedules"
And S.Name 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 120 times (if number of companies participating in Showtime
exceed 120 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


'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 = "COMPANY"
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 = 150
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
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

Private Sub Workbook_WindowResize(ByVal Wn As Window)

If Wn.WindowState = xlMinimized Then
ThisWorkbook.Unprotect Password:="*****"
Else
ThisWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
End If

End Sub
Christophe
Le #22575931
Bonjour:

Merci pour le lien.

L'une des macros concernées (code ci-dessous) a été faite en grande
partie avec l'enregistreur de macro ce qui peut probablement
expliquer son extrême lenteur. Est-ce quelqu'un peut m'aider à
identifier les parties de la macro susceptibles de poser le plus de
problème de rapidité.

Remerciements et sincères salutations.

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 JOLY
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 "Instructions" And S.Name "Company Data" And S.Name <> "Country Appointments" And
S.Name "EmailAllCountrySchedules" And S.Name <> "EmailAllCompanySchedules"
And S.Name 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 120 times (if number of companies participating in Showtime
exceed 120 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


'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 = "COMPANY"
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 = 150
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
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

Private Sub Workbook_WindowResize(ByVal Wn As Window)

If Wn.WindowState = xlMinimized Then
ThisWorkbook.Unprotect Password:="*****"
Else
ThisWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
End If

End Sub
Christophe
Le #22594891
Bonjour et merci:

J'ai essayé de répondre à ce post plusieurs fois mais apparemment san s
succes. J'essaie une nouvelle fois.

Mon code vba (ci-dessous) est pour l'essentiel le resultat de
l'enregistreur de macro auxquel j'ai rajouté des lignes de code
regulierement et est par consequent tres lent. Pouvez-vous m'indiquer
a priori les lignes qui de votre point de vus pose le plus de probleme
et comment il convient de les modifier? Merci d'avance.

Sincères salutations.

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 JOLY
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 "Instructions" And S.Name "Company Data" And S.Name <> "Country Appointments" And
S.Name "EmailAllCountrySchedules" And S.Name <> "EmailAllCompanySchedules"
And S.Name 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


'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 = "COMPANY"
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 = 150
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
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

Private Sub Workbook_WindowResize(ByVal Wn As Window)

If Wn.WindowState = xlMinimized Then
ThisWorkbook.Unprotect Password:="*****"
Else
ThisWorkbook.Protect Password:="*****", Structure:=True,
Windows:úlse
End If

End Sub
Christophe
Le #22600731
On 15 sep, 03:28, "Maude Este"
Bonsour®

"Christophe"  a écrit

> Je souhaiterais savoir s'il existe des outils et ou techniques pour
> diagnostiquer et/ou optimiser et/ou nettoyer le code d'une macro afin
> d'augmenter la rapidité de traitement ou les points de ralentissement .

http://xcell05.free.fr/pages/prog/accvba.htm



Merci Maud:

J'ai essayé de compléter ma demande a plusieurs reprises mais le post
n'a pas été publié.
J'ai par conséquent ouvert un nouveau post.

Remerciements et sincères salutations.

Christophe
Publicité
Poster une réponse
Anonyme