Le code vba (ci-dessous) est pour l'essentiel le resultat de
l'enregistreur de macro auxquel j'ai rajout=E9 des lignes de code
regulierement et est par consequent devenu tres tres tres lent. Pouvez-
vous m'indiquer les lignes qui de votre point de vue pose le plus de
probleme de rapidite et comment les modifier. Merci d'avance pour
votre aide.
Sinc=E8res salutations.
Christophe
Sub ShowtimeCompanyScheduler()
If MsgBox(Prompt:=3D"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:=3DvbYesNo + vbQuestion, _
Title:=3D"Generate Company Schedules") =3D vbNo Then
Exit Sub
End If
' Showtime Scheduler Macro
' Macro enregistr=E9e le 29/04/2003 par Christophe
Application.ScreenUpdating =3D False
' Unprotect Worksheet
ActiveWorkbook.Unprotect Password:=3D"*****"
Worksheets("Company Data").Select
' save last changes made at Worksheet "Country Appointments"
Worksheets("Country Appointments").Select
'ActiveSheet.Unprotect Password:=3D"*****"
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWorkbook.Save
'TEST CreateBackup =3D True
'ActiveSheet.Protect Password:=3D"*****", DrawingObjects:=3DTrue,
Contents:=3DTrue, Scenarios:=3DTrue
'Delete all Worksheets except 9 of them
ActiveWorkbook.Unprotect Password:=3D"*****"
Application.DisplayAlerts =3D 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 =3D False
'Create Copy content-value of "Country Appointments" moins colonne
A into "Transitory1" (no formulas).
Cells.Select
Selection.Copy
Sheets.Add.Name =3D "Transitory1"
Range("A1").Select
Selection.PasteSpecial Paste:=3DxlAll, Operation:=3DxlNone,
SkipBlanks:=3DFalse _
, Transpose:=3DFalse
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 =3D "Transitory1"
Columns("A:A").Select
Application.CutCopyMode =3D False
Selection.Delete Shift:=3DxlToLeft
' Replace "H#" by empty cell otherwise program stop as it cannot
find empty cells in some columns.
'It might be possible and better instead to use something like
"Application.DisplayAlerts =3D False"
Cells.Select
Selection.Replace What:=3D"H#", Replacement:=3D"", LookAt:=3DxlPart, _
SearchOrder:=3DxlByRows, MatchCase:=3DFalse
'Copy and paste result into "Transitory2" worksheet
Cells.Select
Application.CutCopyMode =3D False
Selection.Copy
Range("A1").Select
Sheets.Add.Name =3D "Transitory2"
ActiveSheet.Paste
Columns("A:A").Select
Selection.NumberFormat =3D "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 =3D 1 To 120
If Application.WorksheetFunction.CountA(Range("B2:B115")) =3D 0
Then
GoTo Suite1
End If
'si la cha=EEne "Onglet" est vide
If Onglet =3D "" Then
Onglet =3D "ZZZZZ"
GoTo Suite
End If
'si le nom comprend des caract=E8res interdits -> tiret bas
For j =3D 1 To Len(Onglet)
Select Case Mid(Onglet, j, 1)
Case "&", ":", "/", "\", "?", "*", "[", "]": Mid(Onglet,
j, 1) =3D "_"
End Select
Next
'si le nom est trop long -> tronqu=E9 =E0 31 caract=E8res
If Len(Onglet) > 31 Then
Onglet =3D Left(Onglet, 31)
End If
'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 =3D xlLeft
.VerticalAlignment =3D xlBottom
.WrapText =3D False
.Orientation =3D 0
.AddIndent =3D False
.IndentLevel =3D 0
.ShrinkToFit =3D False
.MergeCells =3D 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 Files\Showtime Scheduler\"
Range("A1").Select
Rows("1:1").RowHeight =3D 110
ActiveSheet.Pictures.Insert("C:\Program Files\Showtime
Scheduler\uscslogo2.jpg").Select
With Selection
.Top =3D Range("A1").Top
.Left =3D Range("A1").Left
.Width =3D Range("A1").Width
.Height =3D Range("A1").Height
End With
'TEST Range("C13").Select
'TEST ActiveCell.Formula =3D "=3DA13&"" ""&B13"
' TEST Range("C13").Select
' TEST Selection.Copy
' TEST Range("D13").Select
' TEST Selection.PasteSpecial Paste:=3DxlValues,
Operation:=3DxlNone, SkipBlanks:=3D _
False, Transpose:=3DFalse
' TEST Range("A13:C13").Select
' TEST Selection.Delete Shift:=3DxlToLeft
' TEST Selection.Font.Bold =3D True
' TEST Range("A13").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 =3D Cells(Rows.Count, "A").End(3).Row
Range("a15:ce" & derlg).Interior.ColorIndex =3D xlNone
For Each ce In Range("a15:a" & derlg)
If Range("a" & ce.Row) & Range("a" & ce.Row + 1) =3D "" Then
Exit For
Range(Cells(ce.Row, 1), Cells(ce.Row,
3)).Interior.ColorIndex =3D 15 * (ce.Row Mod 2)
Next
ActiveWindow.DisplayZeros =3D False
ActiveSheet.PageSetup.PrintArea =3D ("$A$1:$C$" &
Range("A65536").End(xlUp).Row)
With ActiveSheet.PageSetup
'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 =3D False
'ThisWorkbook.Sheets(c.Value).Delete
'Application.DisplayAlerts =3D 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 =3D False
For Each S In Sheets
If S.Name Like "Sheet*" Then S.Delete
Next
Application.DisplayAlerts =3D True
'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:=3D"*****"
ActiveWindow.FreezePanes =3D True
'Range("C2").Activate
'Sheets("Country Appointments").Select
' This Macro below was added to create the Transitory6 sheet which
feed the EmailAllCompanySchedules template.
'Delete all sheets starting with "Sheet" and followed by something
e.g. "sheet1" "sheet 150" sheet"999" etc.
Application.DisplayAlerts =3D 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 =3D True
' This Macro below was added to feed the EmailAllCompanySchedules
with the sheet tab names.
Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Unprotect Password:=3D"*****"
Dim Ws As Worksheet, wb As Workbook, R As Range, Ig As Integer
Set wb =3D ActiveWorkbook
Set R =3D ActiveSheet.Range("C7")
Ig =3D 1
For Each Ws In wb.Worksheets
R.Cells(Ig, 1) =3D Ws.Name
Ig =3D Ig + 1
Next Ws
Sheets("Transitory6").Select
ActiveSheet.Unprotect Password:=3D"*****"
Dim Wst As Worksheet
Dim mystr As String, cr As Range, It As Integer
For Each cr In [C4:C503]
mystr =3D ""
For It =3D 1 To Len(cr)
x =3D Mid(cr, It, 1)
If InStr("/?;*&:[]\", x) > 0 Then
mystr =3D mystr & "_"
Else
mystr =3D mystr & x
End If
Next It
cr.Offset(, -1) =3D mystr
Next cr
Range("A4").Select
ActiveCell.FormulaR1C1 =3D "=3DLEFT(RC[1],31)"
Range("A4").Select
Selection.AutoFill Destination:=3DRange("A4:A503"),
Type:=3DxlFillDefault
Sheets("EmailAllCompanySchedules").Select
ActiveSheet.Protect Password:=3D"*****", DrawingObjects:=3DTrue,
Contents:=3DTrue, Scenarios:=3DTrue _
, AllowFormattingCells:=3DTrue,
AllowFormattingColumns:=3DTrue, _
AllowFormattingRows:=3DTrue
Worksheets("EmailAllCompanySchedules").Select
Range("A8").Select
End Sub
Private Sub Workbook_WindowResize(ByVal Wn As Window)
If Wn.WindowState =3D xlMinimized Then
ThisWorkbook.Unprotect Password:=3D"*****"
Else
ThisWorkbook.Protect Password:=3D"*****", Structure:=3DTrue,
Windows:=3DFalse
End If
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
HD
bonjour,
Pas le temps de lire toute votre macro... mais une piste... optimisez votre vba... il y'a de nombreux articles sur le sujet dont: http://xcell05.free.fr/pages/prog/accvba.htm http://www.info-3000.com/vbvba/conseiloptimisation.php
-- @+ HD
bonjour,
Pas le temps de lire toute votre macro... mais une piste... optimisez votre
vba... il y'a de nombreux articles sur le sujet dont:
http://xcell05.free.fr/pages/prog/accvba.htm
http://www.info-3000.com/vbvba/conseiloptimisation.php
Pas le temps de lire toute votre macro... mais une piste... optimisez votre vba... il y'a de nombreux articles sur le sujet dont: http://xcell05.free.fr/pages/prog/accvba.htm http://www.info-3000.com/vbvba/conseiloptimisation.php
