Macro top lente

Le 14/09/2017 à 17:31

Bonjour

J'ai crée un formulaire qui alimente deux feuilles d'un classeur "HA" et "ST" et ensuite procède à un tri

Le problème c'est que pour ajouter ou modifier un nom , il se passe au moins 45 secondes d'attente. Je pense donc que j'ai du faire des erreurs mais je ne vois pas pas trop où

Ci dessous les codes

Merci

'AJOUTER

Private Sub BtnAjouter_Click()

If CboNom.Value = "" Then

MsgBox "Veuillez renseigner le champs 'Nom' "

Else

Dim ligne As Long

If MsgBox("confirmez l'ajout de données ?", vbYesNo, "confirmation") = vbYes Then

Sheets("ST").Activate

Range("A39").Select

Selection.End(xlDown).Select

Selection.Offset(1, 0).Select

ActiveCell = CboSection.Value

ActiveCell.Offset(0, 1).Value = CboS

ActiveCell.Offset(0, 3).Value = CboG

ActiveCell.Offset(0, 4).Value = CboNom

ActiveCell.Offset(0, 5).Value = TxtPrenom

Dim a As String

Dim b As String

Dim c As String

Dim LiFin(2) As Long

Dim x As Long

Dim y As Long

LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

LiFin(2) = Cells(Rows.Count, 1).End(xlUp).Row

For x = 1 To LiFin(2)

c = c & "µ" & Cells(x, 1)

Next x

c = c & "µ"

For x = 2 To LiFin(1)

a = Cells(x, 4)

If InStr(1, c, a) > 0 Then

Cells(x, 3) = a

Else

Cells(x, 3) = Mid(a, 1, 3)

End If

Next x

Sheets("HA").Activate

Range("A39").Select

Selection.End(xlDown).Select

Selection.Offset(1, 0).Select

ActiveCell = CboSection.Value

ActiveCell.Offset(0, 1).Value = CboS

ActiveCell.Offset(0, 3).Value = CboG

ActiveCell.Offset(0, 4).Value = CboNom

ActiveCell.Offset(0, 5).Value = TxtPrenom

LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

LiFin(2) = Cells(Rows.Count, 39).End(xlUp).Row

For x = 1 To LiFin(2)

c = c & "µ" & Cells(x, 39)

Next x

c = c & "µ"

For x = 2 To LiFin(1)

a = Cells(x, 4)

If InStr(1, c, a) > 0 Then

Cells(x, 3) = a

Else

Cells(x, 3) = Mid(a, 1, 3)

End If

Next x

MsgBox "Bien enregistré", vbOKOnly + vbInformation, "CONFIRMATION"

'

' TRIHA Macro

'

'

Sheets("HA").Select

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(191, 191, 191)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(0, 176, 240)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(0, 176, 80)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(255, 0, 0)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(255, 255, 0)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[SE]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, CustomOrder:="OF,SG,SC,MA,CT,GA,SY,BU", DataOption:= _

xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[[GR]]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, CustomOrder:= _

"AAA,BBB,CCC,DDD,EEE" _

, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[NOM]"), SortOn:=xlSortOnValues, Order:=xlAscending, _

DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[PRENOM]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Range("A6").Select

'TRI Macro

'

'Sheets("ST").Select

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Clear

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("ST]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(191, 191, 191)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(51, 102, 255)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(0, 128, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(255, 255, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne2]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, CustomOrder:="OF,SG,SC,CT,MA,GA,SY,BU,SE", _

DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne4]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, CustomOrder:= _

"AAA,BBB,CCC,DDD,EEE" _

, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne5]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne6]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Range("A6").Select

End If

End If

End Sub

'EFFACER

Private Sub Btnefface_Click()

CboSec = ""

CboSer = ""

CboGr = ""

CboNom = ""

TxtPrenom = ""

End Sub

'MODIFIER

Private Sub BtnModifier_Click()

Dim modif As Long

'Modif sur feuille ha

Sheets("HA").Select

No_ligne = CboNom.ListIndex + 39

If TxtPrenom.Value = "" Then

MsgBox ("Veuillez remplir tous les champs")

Else

Cells(No_ligne, 1) = CboSec.Value

Cells(No_ligne, 2) = CboSer.Value

Cells(No_ligne, 4) = CboGr.Value

Cells(No_ligne, 6) = TxtPrenom.Value

Dim a As String

Dim b As String

Dim c As String

Dim LiFin(2) As Long

Dim x As Long

Dim y As Long

LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

LiFin(2) = Cells(Rows.Count, 39).End(xlUp).Row

For x = 1 To LiFin(2)

c = c & "µ" & Cells(x, 39)

Next x

c = c & "µ"

For x = 2 To LiFin(1)

a = Cells(x, 4)

If InStr(1, c, a) > 0 Then

Cells(x, 3) = a

Else

Cells(x, 3) = Mid(a, 1, 3)

End If

Next x

'Modif sur feuille ST

Sheets("ST").Select

No_ligne = CboNom.ListIndex + 39

Cells(No_ligne, 1) = CboSec.Value

Cells(No_ligne, 2) = CboSer.Value

Cells(No_ligne, 4) = CboGr.Value

Cells(No_ligne, 6) = TxtPrenom.Value

LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

LiFin(2) = Cells(Rows.Count, 1).End(xlUp).Row

For x = 1 To LiFin(2)

c = c & "µ" & Cells(x, 1)

Next x

c = c & "µ"

For x = 2 To LiFin(1)

a = Cells(x, 4)

If InStr(1, c, a) > 0 Then

Cells(x, 3) = a

Else

Cells(x, 3) = Mid(a, 1, 3)

End If

Next x

MsgBox ("Modification effectuée")

Sheets("HA").Select

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(191, 191, 191)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(0, 176, 240)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(0, 176, 80)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(255, 0, 0)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add( _

Range("Tableau4[S]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _

SortOnValue.Color = RGB(255, 255, 0)

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[SE]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, CustomOrder:="OF,SG,SC,MA,CT,GA,SY,BU", DataOption:= _

xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[[GR]]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, CustomOrder:= _

"AAA,BBB,CCC,DDD,EEE" _

, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[NOM]"), SortOn:=xlSortOnValues, Order:=xlAscending, _

DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort.SortFields.Add _

Key:=Range("Tableau4[PRENOM]"), SortOn:=xlSortOnValues, Order:= _

xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("HA").ListObjects("Tableau4").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Range("A6").Select

'Sheets("ST").Select

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Clear

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("ST]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(191, 191, 191)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(51, 102, 255)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(0, 128, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add(Range("Table3[Colonne1]"), xlSortOnCellColor, xlAscending, , _

xlSortNormal).SortOnValue.Color = RGB(255, 255, 0)

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne2]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, CustomOrder:="OF,SG,SC,CT,MA,GA,SY,BU,SE", _

DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne4]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, CustomOrder:= _

"AAA,BBB,CCC,DDD,EEE" _

, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne5]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort. _

SortFields.Add Key:=Range("Table3[Colonne6]"), SortOn:=xlSortOnValues, _

Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("ST").ListObjects("Table3").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Range("A6").Select

End If

End If

End Sub

Unload FORMULAIRE

Load FORMULAIRE

FORMULAIRE.Show

End If

End Sub

'QUITTER le formulaire

Private Sub BtnQuitter_Click()

Unload Me

Sheets("sommaire").Select

End Sub

'RECHERCHER

Private Sub BtnRecherche_Click()

Sheets("HA").Activate

'If CboNom.Value = "" Then

'MsgBox ("Veuillez entrer le nom du fonctionnaire")

If Not CboNom.Value = "" Then

Dim No_ligne As Long

No_ligne = CboNom.ListIndex + 39

CboSec.Value = Cells(No_ligne, 1).Value

CboSer.Value = Cells(No_ligne, 2).Value

CboGr.Value = Cells(No_ligne, 4).Value

TxtPrenom.Value = Cells(No_ligne, 6).Value

Else

End If

'End If

End Sub

'NOM en MAJUSCULE

'Private Sub CboNom_Change()

'CboNom = UCase(CboNom)

'End Sub

'Bloquage bouton AJOUTER

Private Sub TxtPrenom_Change()

If TxtPrenom <> "" Then

BtnAjouter.Enabled = True

Else

BtnAjouter.Enabled = False

End If

TxtPrenom = WorksheetFunction.Proper(TxtPrenom)

End Sub

Private Sub UserForm_Initialize()

'Alimentation CboGrade

Sheets("DONNEES").Activate

Dim No_ligne As Long

No_ligne = 2

Do While Cells(No_ligne, 10).Value <> ""

FORMULAIRE.CboGrade.AddItem Cells(No_ligne, 10).Value

No_ligne = No_ligne + 1

Loop

'Alimentation CboSec

Sheets("DONNEES").Activate

Dim i As Long

i = 2

Do While Cells(i, 6).Value <> ""

FORMULAIRE.CboSec.AddItem Cells(i, 6).Value

i = i + 1

Loop

'Alimentation CboSer

Sheets("DONNEES").Activate

Dim m As Long

m = 2

Do While Cells(m, 8).Value <> ""

FORMULAIRE.CboSer.AddItem Cells(m, 8).Value

m = m + 1

Loop

'Alimentation CboNom

Sheets("HA").Activate

No_ligne = 39

Do While Cells(No_ligne, 5).Value <> ""

FORMULAIRE.CboNom.AddItem Cells(No_ligne, 5).Value

No_ligne = No_ligne + 1

Loop

End Sub

Le 14/09/2017 à 17:51

Salut Tacentaure,

un fichier, stp!

A+

Rechercher des sujets similaires à "macro top lente"