Simplification de code VBA effectué avec enregistrement

Le 21/07/2017 à 06:45

Bonjour à la communauté,

Je sollicite une nouvelle fois les personnes du forum pour simplifier mon code VBA que j'ai créé uniquement avec l'enregistreur. Problème, il fait bugger les (vieux) PC sous Windows sous lesquels le fichier est utilisé (personnellement il fonctionne plutôt rapidement, je travail sur Mac plutôt récent).

Une âme charitable, s'il vous plait, pour m'aider à la simplification de mon enregistrement de commande VBA? Ce code prend les données qui me sont utiles dans les 2 premières feuilles (extraction de données via un site internet) et les ajoutes sur une troisième feuille : "Result". Cette dernière représente la base de mon traitement de données pour la suite de mon fichier.. Bref, voici mon code actuel:

Sub ClicOne()

'

' ClicOne Macro

Sheets("Extract payment").Select

Columns("D:D").Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Columns("C:C").Select

Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _

Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _

:=Array(Array(1, 1), Array(2, 1))

Columns("C:C").Select

Selection.Copy

Sheets("Result").Select

Columns("B:B").Select

ActiveSheet.Paste

Sheets("Extract payment").Select

Columns("D:D").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Result").Select

Columns("C:C").Select

ActiveSheet.Paste

Sheets("Extract payment").Select

Columns("F:F").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Result").Select

Columns("D:D").Select

ActiveSheet.Paste

Sheets("Extract payment").Select

Columns("J:J").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Result").Select

Columns("G:G").Select

ActiveSheet.Paste

Sheets("Extract payment").Select

Columns("L:L").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Result").Select

Columns("H:H").Select

ActiveSheet.Paste

Sheets("Extract payment").Select

Columns("P:P").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Result").Select

Columns("I:I").Select

ActiveSheet.Paste

Range("E1").Select

Application.CutCopyMode = False

ActiveCell.FormulaR1C1 = "Owner name"

Range("E2").Select

ActiveCell.FormulaR1C1 = _

"=IF(ISNA(INDEX('Extract account'!C[20],MATCH(Result!RC[-1],'Extract account'!C[-3],0))),"""",(INDEX('Extract account'!C[20],MATCH(Result!RC[-1],'Extract account'!C[-3],0))))"

Range("D2").Select

Selection.Copy

Range("E2").Select

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range("E2:E9"), Type:=xlFillDefault

Range("E2:E9").Select

Selection.AutoFill Destination:=Range("E2:E7042"), Type:=xlFillDefault

Range("E2:E7042").Select

Range("F1").Select

ActiveCell.FormulaR1C1 = "Account status"

Range("F2").Select

ActiveCell.FormulaR1C1 = _

"=IF(ISNA(INDEX('Extract account'!C[3],MATCH(Result!RC[-2],'Extract account'!C[-4],0))),"""",(INDEX('Extract account'!C[3],MATCH(Result!RC[-2],'Extract account'!C[-4],0))))"

Range("E2").Select

Selection.Copy

Range("F2").Select

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range("F2:F7006"), Type:=xlFillDefault

Range("F2:F7006").Select

Range("J1").Select

ActiveCell.FormulaR1C1 = "Costumer Region"

Range("H1").Select

Selection.Copy

Range("J1").Select

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

Range("J2").Select

ActiveCell.FormulaR1C1 = _

"=IF(ISNA(INDEX('Extract account'!C[22],MATCH(Result!RC[-6],'Extract account'!C[-8],0))),"""",(INDEX('Extract account'!C[22],MATCH(Result!RC[-6],'Extract account'!C[-8],0))))"

Range("J2").Select

Selection.AutoFill Destination:=Range("J2:J3"), Type:=xlFillDefault

Range("J2:J3").Select

Range("I2").Select

Selection.Copy

Range("J2").Select

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range("J2:J7022"), Type:=xlFillDefault

Range("J2:J7022").Select

Columns("B:J").Select

Range("J1").Activate

With Selection

.HorizontalAlignment = xlLeft

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.MergeCells = False

End With

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.ShrinkToFit = False

.MergeCells = False

End With

Selection.ColumnWidth = 18.33

Range("C1:J1").Select

Range("J1").Activate

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 = xlThin

.ColorIndex = xlAutomatic

End With

Selection.Borders(xlEdgeRight).LineStyle = xlNone

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("A11").Select

End Sub

Vous pouvez voir que c'est long et que ça doit bien faire mouliner les PC..

Je rajouterai que ce code est la première partie d'un outil que je souhaite développer avec plusieurs autres macro pour lesquels j'ai déjà sollicité les membres de la communauté ici. Du coup, ce premier code plutôt "pompeux" et peu rapide, ralenti vraiment l'outil.

Le fichier est également en pièce jointe.

Merci à tous pour l'aide sur ce site et merci d'avance aux personnes qui s'arrêterons pour m'aider!

Bonne journée à tous.

17test-forum.xlsm (408.32 Ko)
Le 21/07/2017 à 08:35

Bonjour,

Essaie comme ça :

Sub ClicOne()
   With Sheets("Extract payment")
      .Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      .Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
          Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
          :=Array(Array(1, 1), Array(2, 1))
      .Columns("C:C").Copy Sheets("Result").Columns("B:B")
      .Columns("D:D").Copy Sheets("Result").Columns("C:C")
      .Columns("F:F").Copy Sheets("Result").Columns("D:D")
      .Columns("J:J").Copy Sheets("Result").Columns("G:G")
      .Columns("L:L").Copy Sheets("Result").Columns("H:H")
      .Columns("P:P").Copy Sheets("Result").Columns("I:I")
   End With
   Sheets("Result").Activate
       Range("E1") = "Owner name"
       Range("F1") = "Account status"
       Range("J1") = "Costumer Region"
       Range("E2").Formula = _
           "=IF(ISNA(INDEX('Extract account'!Y:Y,MATCH(Result!D2,'Extract account'!B:B,0))),"""",(INDEX('Extract account'!Y:Y,MATCH(Result!D2,'Extract account'!B:B,0))))"
       Range("D2").Copy
       Range("E2").PasteSpecial Paste:=xlFormats, Operation:=xlNone
       Range("E2").AutoFill Destination:=Range("E2:E7000"), Type:=xlFillDefault
       Range("F2").Formula = _
           "=IF(ISNA(INDEX('Extract account'!I:I,MATCH(Result!D2,'Extract account'!B:B,0))),"""",(INDEX('Extract account'!I:I,MATCH(Result!D2,'Extract account'!B:B,0))))"
       Range("E2").Copy
       Range("F2").PasteSpecial Paste:=xlFormats, Operation:=xlNone
       Range("F2").AutoFill Destination:=Range("F2:F7000"), Type:=xlFillDefault
       Range("J2").Formula = _
           "=IF(ISNA(INDEX('Extract account'!AF:AF,MATCH(Result!D2,'Extract account'!B:B,0))),"""",(INDEX('Extract account'!AF:AF,MATCH(Result!D2,'Extract account'!B:B,0))))"
       Range("I2").Copy
       Range("J2").PasteSpecial Paste:=xlFormats, Operation:=xlNone
       Range("J2").AutoFill Destination:=Range("J2:J7000"), Type:=xlFillDefault
   Columns("B:J").Select
   With Selection
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlBottom
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .ShrinkToFit = False
       .MergeCells = False
   End With
   Selection.ColumnWidth = 18.33
   Range("B1:J1").Borders(xlEdgeBottom).LineStyle = xlContinuous
   Range("A1").Select
End Sub

A+

Nota : Si ça bug encore sur les vieux PC essaie en supprimant ces 5 lignes :

       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .ShrinkToFit = False
       .MergeCells = False
18test-forum-vg.xlsm (429.15 Ko)
Le 21/07/2017 à 10:21

Hello,

Oui merci beaucoup, ça fonctionne bien!

Ça mouline toujours encore un peu, mais moins.

Cela ne viendrait-il pas (et je n'ai pas réussi à trouver à travers le site comment faire) du fait que j'ai prédéfini manuellement les formules à s'appliquer jusqu'à la ligne 7000 et non pas jusqu'à la dernière "écrite" :

Range("E2").AutoFill Destination:=Range("E2:E7000"), Type:=xlFillDefault

Range("F2").AutoFill Destination:=Range("F2:F7000"), Type:=xlFillDefault

Range("J2").AutoFill Destination:=Range("J2:J7000"), Type:=xlFillDefault

Ce qui pousserait Excel à mouliner bien plus? Je n'ai pas la réponse..

Encore merci galopin01!

Le 21/07/2017 à 11:01

Modifie comme suit :

Sub ClicOne()
Application.ScreenUpdating = False 'insérer cette ligne
   With Sheets("Extract payment") 'la suite sans changement

A+

Le 21/07/2017 à 11:16

Bonjour Galopin01, Ek0 et le forum

est que ca mouline car tu est sous mac ou tu test sur pc

Le 21/07/2017 à 11:36

Oui... Le MAC C'est un peu comme vouloir aller à la pêche avec une "canne de golf !"

Oui on pourrait améliorer en testant le nombre de ligne. Mais le gain de temps ne serait pas significatif.

Cette dernière modif devrait suffire :

Sub ClicOne()
Application.ScreenUpdating = False 'insérer cette ligne
  With Sheets("Extract payment") 'la suite sans changement

A+

Le 25/07/2017 à 04:01

Oups, désolé je n'avais pas vu!

Salut tous le monde!

@grisan29, sur mon MAC ça fonctionne rapidement! En fait, je travail depuis mon MAC pour "développer" l'outil qui sera utilisé sur WINDOWS par la suite. C'est sur ces derniers que l'outil mouline énormément...

@galopin01, merci, j'ai noté une amélioration! Toutefois, ça mouline toujours un peu.. Je ne pense pas que ce soit un problème lié à l'ancienneté des PC.

Je radote peut-être mais il n'y aurait pas un code permettant d'aller chercher uniquement la dernière ligne écrite de la feuille plutôt que d'aller jusqu'à la 7000ème?

Merci d'avance et bonne journée à tous!

Le 25/07/2017 à 06:19

bonjour,

Je n'y crois vraiment pas : chez moi ce code est instantané.

Si c'est long c'est que le PC à d'autres soucis. (Gestion de mémoire, réseau...)

Modifie comme suit :

Sub ClicOne()
Dim k&
   With Sheets("Extract payment")
   k = .Range("A1").CurrentRegion.Rows.Count
'...
       Range("E2").AutoFill Destination:=Range("E2:E" & k), Type:=xlFillDefault
'...
       Range("F2").AutoFill Destination:=Range("F2:F" & k), Type:=xlFillDefault
'...
       Range("J2").AutoFill Destination:=Range("J2:J" & k), Type:=xlFillDefault 'la suite sans changement

A+

Le 25/07/2017 à 09:02

Bonjour galopin01,

C'est bon, cette fois ci c'est la bonne, tout fonctionne!

Merci beaucoup et à bientôt sur le forum!

A+

Rechercher des sujets similaires à "simplification code vba effectue enregistrement"